home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / BCHMMG.C < prev    next >
C/C++ Source or Header  |  1992-06-03  |  99KB  |  3,380 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/src/microcode/RCS/bchmmg.c,v 9.75 1992/06/03 21:55:24 jinx Exp $
  4.  
  5. Copyright (c) 1987-1992 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* Memory management top level.  Garbage collection to disk. */
  36.  
  37. #include "scheme.h"
  38. #include "prims.h"
  39. #include "option.h"
  40. #include "oscond.h"
  41.  
  42. #ifdef DOS386
  43. #  include "msdos.h"
  44. #  define SUB_DIRECTORY_DELIMITER '\\'
  45. extern char * EXFUN (mktemp, (char *));
  46. #else
  47. #  include "ux.h"
  48. #  define SUB_DIRECTORY_DELIMITER '/'
  49. #  define UNLINK_BEFORE_CLOSE
  50. extern int EXFUN (unlink, (CONST char *));
  51. #endif
  52.  
  53. #include "bchgcc.h"
  54. #include "bchdrn.h"
  55.  
  56. #ifndef SEEK_SET
  57. #  define SEEK_SET 0
  58. #endif
  59.  
  60. #ifdef HAVE_SYSV_SHARED_MEMORY
  61. #  define RECORD_GC_STATISTICS
  62. #endif
  63. #define MILLISEC * 1000
  64.  
  65. /* Memory management top level.  Garbage collection to disk.
  66.  
  67.    The algorithm is basically the same as for the 2 space collector,
  68.    except that new space is on the disk, and there are two windows to
  69.    it (the scan and free buffers).  The two windows are physically the
  70.    same whent they correspond to the same section of the address space.
  71.    There may be additional windows used to overlap I/O.
  72.  
  73.    For information on the 2 space collector, read the comments in the
  74.    replaced files.
  75.  
  76.    The memory management code is spread over the following files:
  77.    - bchgcc.h: shared header file for bchscheme.
  78.    - bchmmg.c: top level, initialization and I/O.    Replaces memmag.c
  79.    - bchgcl.c: main garbage collector loop.        Replaces gcloop.c
  80.    - bchpur.c: constant/pure space hacking.        Replaces purify.c
  81.    - bchdmp.c: object & world image dumping.        Replaces fasdump.c
  82.    - bchdrn.h: header file for bchmmg.c and the bchdrn.c.
  83.    - bchdrn.c: stand-alone program used as an overlapped I/O drone.
  84.    - bchutl.c: utilities common to bchmmg.c and bchdrn.c.
  85.  
  86.    Problems with this implementation right now:
  87.    - Purify kills Scheme if there is not enough space in constant space
  88.      for the new object.
  89.    - It only works on Unix (or systems which support Unix I/O calls).
  90.    - Dumpworld does not work because the file is not closed at dump time or
  91.      reopened at restart time.
  92.    - Command-line specified gc files are only locked on versions of Unix
  93.      that have lockf(2).  If your system does not have lockf, two
  94.      processes can try to share the file and get very confused.
  95.  
  96. oo
  97.    ------------------------------------------
  98.    |        GC Buffer Space                 | (not always contiguous)
  99.    |                                        |
  100.    ------------------------------------------
  101.    |         Control Stack        ||        |
  102.    |                              \/        |
  103.    ------------------------------------------
  104.    |     Constant + Pure Space    /\        |
  105.    |                              ||        |
  106.    ------------------------------------------
  107.    |          Heap Space                    |
  108.    |                                        |
  109.    ------------------------------------------
  110. 0
  111.    Each area has a pointer to its starting address and a pointer to
  112.    the next free cell.  The GC buffer space contains two (or more)
  113.    buffers used during the garbage collection process.  One is the
  114.    scan buffer and the other is the free buffer, and they are dumped
  115.    and loaded from disk as necessary.  At the beginning and at the end
  116.    a single buffer is used, since transporting will occur into the
  117.    area being scanned.
  118. */
  119.  
  120. /* Exports */
  121.  
  122. extern void EXFUN (Clear_Memory, (int, int, int));
  123. extern void EXFUN (Setup_Memory, (int, int, int));
  124. extern void EXFUN (Reset_Memory, (void));
  125.  
  126. long
  127.   gc_file_end_position,
  128.   gc_file_current_position,
  129.   gc_file_start_position;
  130.  
  131. unsigned long
  132.   gc_buffer_size,
  133.   gc_buffer_bytes,
  134.   gc_buffer_shift,
  135.   gc_buffer_mask,
  136.   gc_buffer_byte_shift;
  137.  
  138. static unsigned long
  139.   gc_extra_buffer_size,
  140.   gc_buffer_overlap_bytes,
  141.   gc_buffer_remainder_bytes,
  142.   gc_total_buffer_size;
  143.  
  144. SCHEME_OBJECT
  145.   * scan_buffer_top,        * scan_buffer_bottom,
  146.   * free_buffer_top,        * free_buffer_bottom,
  147.   * virtual_scan_pointer;
  148.  
  149. static SCHEME_OBJECT
  150.   * virtual_scan_base;
  151.  
  152. static char
  153.   * gc_file_name = ((char *) NULL),
  154.   gc_file_name_buffer[FILE_NAME_LENGTH];
  155.  
  156. CONST char
  157.   * drone_file_name = ((char *) NULL);
  158.  
  159. static int
  160.   keep_gc_file_p = 0,
  161.   gc_file = -1,
  162.   read_overlap = 0,
  163.   write_overlap = 0;
  164.  
  165. static SCHEME_OBJECT
  166.   * aligned_heap;
  167.  
  168. static Boolean
  169.   can_dump_directly_p,
  170.   extension_overlap_p,
  171.   scan_buffer_extended_p;
  172.  
  173. static long
  174.   scan_position,
  175.   free_position,
  176.   pre_read_position,
  177.   extension_overlap_length,
  178.   saved_heap_size;
  179.  
  180. static unsigned long
  181.   read_queue_bitmask; /* Change MAX_READ_OVERLAP if you change this. */
  182.  
  183. static struct buffer_info
  184.   * free_buffer,
  185.   * scan_buffer,
  186.   * next_scan_buffer;
  187.  
  188. int
  189. DEFUN (io_error_always_abort, (operation_name, noise),
  190.        char * operation_name AND char * noise)
  191. {
  192.   return (1);
  193. }
  194.  
  195. extern char EXFUN (userio_choose_option,
  196.            (CONST char *, CONST char *, CONST char **));
  197. extern int EXFUN (userio_confirm, (CONST char *));
  198.  
  199. int 
  200. DEFUN (io_error_retry_p, (operation_name, noise),
  201.        char * operation_name AND char * noise)
  202. {
  203.   static CONST char * retry_choices [] =
  204.     {
  205.       "A = abort the operation",
  206.       "E = exit scheme",
  207.       "K = kill scheme",
  208.       "Q = quit scheme",
  209.       "R = retry the operation",
  210.       "S = sleep for 1 minute and retry the operation",
  211.       "X = exit scheme",
  212.       0};
  213.  
  214.   fprintf (stderr,
  215.        "\n%s (%s): GC file error (errno = %s) when manipulating %s.\n",
  216.        scheme_program_name, operation_name, (error_name (errno)), noise);
  217.   fflush (stderr);
  218.   while (1)
  219.   {
  220.     switch (userio_choose_option
  221.         ("Choose one of the following actions:",
  222.          "Action -> ", retry_choices))
  223.     {
  224.       case 'A':
  225.     return (1);
  226.  
  227.       case '\0':
  228.     /* IO problems, assume everything is scrod. */
  229.     fprintf
  230.       (stderr,
  231.        "%s (io_error_retry_p): Problems reading the keyboard; Exitting.\n",
  232.        scheme_program_name);
  233.     fflush (stderr);
  234.     termination_eof ();
  235.     /*NOTREACHED*/
  236.  
  237.       case 'E': case 'K': case 'Q': case 'X':
  238.     if (!(userio_confirm ("Kill Scheme (Y/N)? ")))
  239.       continue;
  240.     Microcode_Termination (TERM_EXIT);
  241.     /*NOTREACHED*/
  242.  
  243.       case 'S':
  244.     sleep (60);
  245.     /* fall through */
  246.  
  247.       case 'R':
  248.       default:
  249.     return (0);
  250.     }
  251.   }
  252. }
  253.  
  254. static int
  255. DEFUN (verify_write, (position, size, success),
  256.        long position AND long size AND Boolean * success)
  257. {
  258.   if ((position >= gc_file_start_position)
  259.       && ((position + size) <= gc_file_end_position))
  260.     return (0);
  261.   fprintf (stderr,
  262.        "\n%s (verify_write): attempting to write outside allowed area.\n",
  263.        scheme_program_name);
  264.   fprintf (stderr, "\tlow position = 0x%lx; high position = 0x%lx.\n",
  265.        gc_file_start_position, gc_file_end_position);
  266.   fprintf (stderr, "\twrite position = 0x%lx; size = 0x%lx = %d bytes.\n",
  267.        position, size, size);
  268.   fflush (stderr);
  269.   if (success == ((Boolean *) NULL))
  270.   {
  271.     Microcode_Termination (TERM_EXIT);
  272.     /*NOTREACHED*/
  273.   }
  274.   *success = ((Boolean) false);
  275.   return (-1);
  276. }
  277.  
  278. static void
  279. DEFUN (write_data, (from, position, nbytes, noise, success),
  280.        char * from AND long position AND long nbytes
  281.        AND char * noise AND Boolean * success)
  282. {
  283.   if (((verify_write (position, nbytes, success)) != -1)
  284.       && ((retrying_file_operation (write,
  285.                     gc_file,
  286.                     from,
  287.                     position,
  288.                     nbytes,
  289.                     "write",
  290.                     noise,
  291.                     &gc_file_current_position,
  292.                     ((success == ((Boolean *) NULL))
  293.                      ? io_error_retry_p
  294.                      : io_error_always_abort)))
  295.       == -1)
  296.       && (success != ((Boolean *) NULL)))
  297.     *success = false;
  298.   return;
  299. }
  300.  
  301. static void
  302. DEFUN (load_data, (position, to, nbytes, noise, success),
  303.        long position AND char * to AND long nbytes
  304.        AND char * noise AND Boolean * success)
  305. {
  306.   (void) (retrying_file_operation (read,
  307.                    gc_file,
  308.                    to,
  309.                    position,
  310.                    nbytes,
  311.                    "read",
  312.                    noise,
  313.                    &gc_file_current_position,
  314.                    ((success == ((Boolean *) NULL))
  315.                     ? io_error_retry_p
  316.                     : io_error_always_abort)));
  317.   return;
  318. }
  319.  
  320. static int
  321. DEFUN (parameterization_termination, (kill_p, init_p),
  322.        int kill_p AND int init_p)
  323. {
  324.   fflush (stderr);
  325.   if (init_p)
  326.     termination_init_error ();            /*NOTREACHED*/
  327.   else if (kill_p)
  328.     Microcode_Termination (TERM_EXIT);        /*NOTREACHED*/
  329.   else
  330.     return (-1);
  331. }
  332.  
  333. #ifdef SIGCONT
  334. static void
  335. DEFUN (continue_running, (sig), int sig)
  336. {
  337.   RE_INSTALL_HANDLER (SIGCONT, continue_running);
  338.   return;
  339. }
  340. #endif
  341.  
  342. struct bch_GC_statistic
  343. {
  344.   char * name;
  345.   long * counter;
  346. };
  347.  
  348. #ifdef RECORD_GC_STATISTICS
  349.  
  350. static void EXFUN (statistics_clear, (void));
  351. static void EXFUN (statistics_print, (int, char *));
  352.  
  353. #  define STATISTICS_INCR(name)            name += 1
  354. #  define STATISTICS_CLEAR()            statistics_clear ()
  355. #  define STATISTICS_PRINT(level, noise)    statistics_print (level, noise)
  356.  
  357. #else
  358.  
  359. static struct bch_GC_statistic all_gc_statistics[] =
  360. { { "invalid last statistic",        ((long *) NULL) } };
  361.  
  362. #  define STATISTICS_INCR(name)            do { } while (0)
  363. #  define STATISTICS_CLEAR()            do { } while (0)
  364. #  define STATISTICS_PRINT(level, noise)    do { } while (0)
  365.  
  366. #endif
  367.  
  368. #ifdef HAVE_SYSV_SHARED_MEMORY
  369.  
  370. #ifdef RECORD_GC_STATISTICS
  371.  
  372. static long
  373.   reads_not_overlapped,
  374.   reads_overlapped,
  375.   reads_ready,
  376.   reads_queued,
  377.   reads_pending,
  378.   reads_overlapped_aborted,
  379.   reads_found_in_write_queue,
  380.   reads_found_ready,
  381.   read_wait_cycles,
  382.   writes_not_overlapped,
  383.   writes_overlapped,
  384.   writes_not_deferred,
  385.   writes_restarted,
  386.   writes_retried,
  387.   writes_pending,
  388.   write_wait_cycles,
  389.   pre_reads_aborted,
  390.   pre_reads_ignored,
  391.   pre_reads_found_in_write_queue,
  392.   pre_reads_found_ready,
  393.   pre_reads_not_started,
  394.   pre_reads_started,
  395.   pre_reads_deferred,
  396.   pre_reads_restarted,
  397.   pre_reads_retried,
  398.   pre_reads_not_retried,
  399.   pre_reads_requeued_as_writes,
  400.   ready_buffers_enqueued,
  401.   ready_buffers_not_enqueued,
  402.   drone_wait_cycles,
  403.   drone_request_failures,
  404.   drones_found_dead,
  405.   sleeps_interrupted,  
  406.   await_io_cycles,
  407.   gc_start_time,
  408.   gc_end_transport_time,
  409.   gc_end_weak_update_time,
  410.   gc_start_reload_time,
  411.   gc_end_time;
  412.  
  413. #define START_TRANSPORT_HOOK()                        \
  414.   gc_start_time = ((long) (OS_real_time_clock ()))
  415.   
  416. #define END_TRANSPORT_HOOK()                        \
  417.   gc_end_transport_time = ((long) (OS_real_time_clock ()))
  418.  
  419. #define END_WEAK_UPDATE_HOOK()                        \
  420.   gc_end_weak_update_time = ((long) (OS_real_time_clock ()))
  421.  
  422. #define START_RELOAD_HOOK()                        \
  423.   gc_start_reload_time = ((long) (OS_real_time_clock ()))
  424.  
  425. #define END_GC_HOOK()                            \
  426.   gc_end_time = ((long) (OS_real_time_clock ()))
  427.  
  428. static struct bch_GC_statistic all_gc_statistics[] =
  429. {
  430.   { "reads not overlapped",        &reads_not_overlapped },
  431.   { "reads overlapped",            &reads_overlapped },
  432.   { "reads ready",            &reads_ready },
  433.   { "reads queued",            &reads_queued },
  434.   { "reads pending",            &reads_pending },
  435.   { "reads overlapped aborted",        &reads_overlapped_aborted },
  436.   { "reads found in write queue",    &reads_found_in_write_queue },
  437.   { "reads found ready",        &reads_found_ready },
  438.   { "read wait cycles",            &read_wait_cycles },
  439.   { "writes not overlapped",        &writes_not_overlapped },
  440.   { "writes overlapped",        &writes_overlapped },
  441.   { "writes retried",            &writes_retried },
  442.   { "writes not deferred",        &writes_not_deferred },
  443.   { "writes restarted",            &writes_restarted },
  444.   { "writes retried",            &writes_retried },
  445.   { "writes pending",            &writes_pending },
  446.   { "write wait cycles",        &write_wait_cycles },
  447.   { "pre-reads aborted",        &pre_reads_aborted },
  448.   { "pre-reads ignored",        &pre_reads_ignored },
  449.   { "pre-reads found in write queue",    &pre_reads_found_in_write_queue },
  450.   { "pre-reads found ready",        &pre_reads_found_ready },
  451.   { "pre-reads not started",        &pre_reads_not_started },
  452.   { "pre-reads started",        &pre_reads_started },
  453.   { "pre-reads deferred",        &pre_reads_deferred },
  454.   { "pre-reads restarted",        &pre_reads_restarted },
  455.   { "pre-reads retried",        &pre_reads_retried },
  456.   { "pre-reads not retried",        &pre_reads_not_retried },
  457.   { "pre-reads requeued as writes",    &pre_reads_requeued_as_writes },
  458.   { "ready buffers enqueued",        &ready_buffers_enqueued },
  459.   { "ready buffers not enqueued",    &ready_buffers_not_enqueued },
  460.   { "drone wait cycles",        &drone_wait_cycles },
  461.   { "drone request failures",        &drone_request_failures },
  462.   { "drones found dead",        &drones_found_dead },
  463.   { "sleeps interrupted",        &sleeps_interrupted },
  464.   { "cycles awaiting I/O completion",    &await_io_cycles },
  465.   { "time at gc start",            &gc_start_time },
  466.   { "time at end of transport",        &gc_end_transport_time },
  467.   { "time at end of weak update",    &gc_end_weak_update_time },
  468.   { "time at start of reload",        &gc_start_reload_time },
  469.   { "time at gc end",            &gc_end_time },
  470.   { "invalid last statistic",        ((long *) NULL) }
  471. };
  472.  
  473. #endif /* RECORD_GC_STATISTICS */
  474.  
  475. /* The limit on MAX_READ_OVERLAP is the number of bits in read_queue_bitmask.
  476.    The limit on MAX_GC_DRONES is the number of bits in (* wait_mask).
  477.    There is no direct limit on MAX_WRITE_OVERLAP.
  478.    On the other hand, the explicit searches through the queues
  479.    will become slower as the numbers are increased.
  480.  */
  481.  
  482. #define MAX_READ_OVERLAP    ((sizeof (long)) * CHAR_BIT)
  483. #define MAX_WRITE_OVERLAP    MAX_READ_OVERLAP
  484. #define MAX_GC_DRONES        ((sizeof (long)) * CHAR_BIT)
  485. #define MAX_OVERLAPPED_RETRIES    2
  486.  
  487. static char * shared_memory = ((char *) -1);
  488. static char * malloc_memory = ((char *) NULL);
  489. static int drones_initialized_p = 0;
  490. static int shmid = -1;
  491. static int n_gc_buffers, n_gc_drones, gc_next_buffer, gc_next_drone;
  492. static struct gc_queue_entry * gc_read_queue, * gc_write_queue;
  493. static struct drone_info * gc_drones;
  494. static struct buffer_info * gc_buffers;
  495. static unsigned long * wait_mask, * drone_version;
  496.  
  497. static long default_sleep_period = 20 MILLISEC;
  498.  
  499. #define GET_SLEEP_DELTA()    default_sleep_period
  500. #define SET_SLEEP_DELTA(value)    default_sleep_period = (value)
  501.  
  502. #if !(defined(_HPUX) && (_HPUX_VERSION >= 80))
  503. extern int EXFUN (select, (int, int *, int *, int *, struct timeval *));
  504. #endif
  505.  
  506. static void
  507. DEFUN (sleep_awaiting_drones, (microsec, mask),
  508.        unsigned int microsec AND unsigned long mask)
  509. {
  510.   int dummy, saved_errno;
  511.   struct timeval timeout;
  512.  
  513.   dummy = 0;
  514.   timeout.tv_sec = 0;
  515.   timeout.tv_usec = microsec;
  516.  
  517.   *wait_mask = mask;
  518.   dummy = (select (0, &dummy, &dummy, &dummy, &timeout));
  519.   *wait_mask = ((unsigned long) 0);
  520.   saved_errno = errno;
  521.  
  522.   if ((dummy == -1) && (saved_errno == EINTR))
  523.     STATISTICS_INCR (sleeps_interrupted);
  524.   return;
  525. }
  526.  
  527. #ifndef _SUNOS4
  528. #  define SYSV_SPRINTF sprintf
  529. #else
  530. /* Losing SunOS sprintf */
  531.  
  532. #  define SYSV_SPRINTF sysV_sprintf
  533.  
  534. static int
  535. DEFUN (sysV_sprintf, (string, format, value),
  536.        char * string AND char * format AND long value)
  537. {
  538.   sprintf (string, format, value);
  539.   return (strlen (string));
  540. }
  541.  
  542. #endif /* _SUNOS4 */
  543.  
  544. static void
  545. DEFUN (start_gc_drones, (first_drone, how_many, restarting),
  546.        int first_drone AND int how_many AND int restarting)
  547. {
  548.   pid_t pid;
  549.   long signal_mask;
  550.   char arguments[512];
  551.   struct drone_info *drone;
  552.   char
  553.     * shmid_string,        /* shared memory handle */
  554.     * tdron_string,        /* total number of drones */
  555.     * nbuf_string,        /* total number of buffers */
  556.     * bufsiz_string,        /* size of each buffer in bytes */
  557.     * sdron_string,        /* index of first drone to start */
  558.     * ndron_string;        /* number of drones to start */
  559.  
  560.   shmid_string = &arguments[0];
  561.   tdron_string =
  562.     (shmid_string + (1 + (SYSV_SPRINTF (shmid_string, "%d", shmid))));
  563.   nbuf_string =
  564.     (tdron_string + (1 + (SYSV_SPRINTF (tdron_string, "%d", n_gc_drones))));
  565.   bufsiz_string =
  566.     (nbuf_string + (1 + (SYSV_SPRINTF (nbuf_string, "%d", n_gc_buffers))));
  567.   sdron_string =
  568.     (bufsiz_string
  569.      + (1 + (SYSV_SPRINTF (bufsiz_string, "%ld",
  570.                (gc_total_buffer_size
  571.                 * (sizeof (SCHEME_OBJECT)))))));
  572.   ndron_string =
  573.     (sdron_string + (1 + (SYSV_SPRINTF (sdron_string, "%d", first_drone))));
  574.   (void) (SYSV_SPRINTF (ndron_string, "%d", how_many));
  575.  
  576.   drone = (gc_drones + first_drone);
  577.   if (restarting && (drone->state != drone_dead))
  578.     (void) (kill (drone->DRONE_PID, SIGTERM));
  579.   drone->state = drone_not_ready;
  580.   (* drone_version) = ((unsigned long) DRONE_VERSION_NUMBER);
  581.  
  582.   if ((pid = (vfork ())) == 0)
  583.   {
  584.     execlp (drone_file_name, drone_file_name, gc_file_name, shmid_string,
  585.         tdron_string, nbuf_string, bufsiz_string,
  586.         sdron_string, ndron_string, (keep_gc_file_p ? "1" : "0"),
  587.         ((char *) 0));
  588.     fprintf (stderr,
  589.          "\n%s (start_gc_drones): execlp (%s) failed (errno = %s).\n",
  590.          scheme_program_name, drone_file_name, (error_name (errno)));
  591.     fflush (stderr);
  592.     drone->state = drone_dead;
  593.     (void) (kill ((getppid ()), SIGCONT));
  594.     _exit (1);
  595.   }
  596.   else if (pid == -1)
  597.   {
  598.     fprintf (stderr, "\n%s (start_gc_drones): vfork failed (errno = %s).\n",
  599.          scheme_program_name, (error_name (errno)));
  600.     fflush (stderr);
  601.     drone->state = drone_dead;
  602.   }
  603.   else
  604.   {
  605.  
  606.     sigset_t old_mask, new_mask;
  607.  
  608.     UX_sigemptyset (&new_mask);
  609.     UX_sigaddset ((&new_mask), SIGCONT);
  610.     UX_sigprocmask (SIG_BLOCK, (&new_mask), (&old_mask));
  611.     if (drone->state == drone_not_ready)
  612.       UX_sigsuspend (&old_mask);
  613.     UX_sigprocmask (SIG_SETMASK, (&old_mask), 0);
  614.  
  615.     if ((drone->state != drone_idle) && !restarting)
  616.     {
  617.       /* Do the wait only at startup since Scheme handles SIGCHLD
  618.      for all children. */
  619.       ((void) (waitpid (pid, ((int *) 0), WNOHANG)));
  620.       drone->state = drone_dead;
  621.     }
  622.   }
  623.   return;
  624. }
  625.  
  626. static int
  627. DEFUN (invoke_gc_drone,
  628.        (entry, operation, buffer, position, size),
  629.        struct gc_queue_entry * entry
  630.        AND enum drone_state operation
  631.        AND struct buffer_info * buffer
  632.        AND long position
  633.        AND long size)
  634. {
  635.   int result, drone_index;
  636.   struct drone_info * drone;
  637.   enum buffer_state old_state;
  638.  
  639.   drone_index = (entry->drone_index);
  640.   drone = (gc_drones + drone_index);
  641.   drone->buffer_index = buffer->index;
  642.   drone->entry_offset = (((char *) entry) - ((char *) drone));
  643.   
  644.   old_state = buffer->state;
  645.   buffer->state = ((operation == drone_reading)
  646.            ? buffer_being_read
  647.            : buffer_being_written);
  648.   buffer->position = position;
  649.   buffer->size = size;
  650.   entry->buffer = buffer;
  651.   entry->state = entry_busy;
  652.  
  653.   drone->state = operation;    /* Previously drone_idle */
  654.   if ((result = (kill (drone->DRONE_PID, SIGCONT))) == -1)
  655.   {
  656.     entry->state = entry_idle;
  657.     buffer->state = old_state;
  658.     drone->state = drone_dead;
  659.     if (errno != ESRCH)
  660.     {
  661.       fprintf
  662.     (stderr,
  663.      "\n%s (invoke_gc_drone): kill (%d, SIGCONT) failed; errno = %s.\n",
  664.      scheme_program_name, drone->DRONE_PID, (error_name (errno)));
  665.       fflush (stderr);
  666.     }
  667.     start_gc_drones (drone_index, 1, 1);
  668.   }
  669.   return (result != -1);
  670. }
  671.  
  672. /* The following don't do a wait/waitpid because Scheme handles SIGCHLD. */
  673.  
  674. static void
  675. DEFUN_VOID (kill_all_gc_drones)
  676. {
  677.   int count;
  678.   struct drone_info * drone;
  679.  
  680.   for (count = 0, drone = gc_drones; count < n_gc_drones; count++, drone++)
  681.     (void) (kill (drone->DRONE_PID, SIGTERM));
  682.   return;
  683. }
  684.  
  685. static int
  686. DEFUN (probe_gc_drone, (drone), struct drone_info * drone)
  687. {
  688.   int result;
  689.  
  690.   if ((result = (kill ((drone->DRONE_PID), 0))) == -1)
  691.   {
  692.     if (errno != ESRCH)
  693.       (void) (kill ((drone->DRONE_PID), SIGTERM));
  694.     drone->state = drone_dead;
  695.   }
  696.   return (result == 0);
  697. }
  698.  
  699. static void EXFUN (handle_drone_death, (struct drone_info *));
  700.  
  701. static void
  702. DEFUN (probe_all_gc_drones, (wait_p), int wait_p)
  703. {
  704.   int count;
  705.   unsigned long running;
  706.   struct drone_info * drone;
  707.  
  708.   do {
  709.     for (count = 0, drone = gc_drones, running = ((unsigned long) 0);
  710.      count < n_gc_drones;
  711.      count++, drone++)
  712.     {
  713.       if (drone->state != drone_idle)
  714.       {
  715.     running |= (((unsigned long) 1) << drone->index);
  716.     if ((kill (drone->DRONE_PID, 0)) == -1)
  717.     {
  718.       if (errno != ESRCH)
  719.         (void) (kill (drone->DRONE_PID, SIGTERM));
  720.       drone->state = drone_dead;
  721.       start_gc_drones (drone->index, 1, 1);
  722.       handle_drone_death (drone);
  723.     }
  724.       }
  725.     }
  726.     if (wait_p && (running != ((unsigned long) 0)))
  727.     {
  728.       sleep_awaiting_drones (default_sleep_period, running);
  729.       STATISTICS_INCR (await_io_cycles);
  730.     }
  731.   } while (wait_p && (running != ((unsigned long) 0)));
  732.   return;
  733. }
  734.  
  735. static void EXFUN (open_gc_file, (long, int));
  736.  
  737. static int
  738. DEFUN (sysV_initialize, (first_time_p, size, r_overlap, w_overlap, drfnam),
  739.        int first_time_p
  740.        AND long size AND int r_overlap AND int w_overlap
  741.        AND CONST char * drfnam)
  742. {
  743.   SCHEME_OBJECT * bufptr;
  744.   int cntr;
  745.   long buffer_space, shared_size, malloc_size;
  746.   struct buffer_info * buffer;
  747.  
  748.   if (r_overlap < 0)
  749.     r_overlap = 0;
  750.   else if (r_overlap > MAX_READ_OVERLAP)
  751.     r_overlap = MAX_READ_OVERLAP;
  752.   read_overlap = r_overlap;
  753.  
  754.   if (w_overlap < 0)
  755.     w_overlap = 0;
  756.   else if (w_overlap > MAX_WRITE_OVERLAP)
  757.     w_overlap = MAX_WRITE_OVERLAP;
  758.   write_overlap = w_overlap;
  759.  
  760.   if ((n_gc_drones = (read_overlap + write_overlap)) > MAX_GC_DRONES)
  761.   {
  762.     read_overlap = ((read_overlap * MAX_GC_DRONES) / n_gc_drones);
  763.     write_overlap = ((write_overlap * MAX_GC_DRONES) / n_gc_drones);
  764.     n_gc_drones = (read_overlap + write_overlap);
  765.   }
  766.   n_gc_buffers = (2 + n_gc_drones);
  767.  
  768.   /* The second argument to open_gc_file should be (n_gc_drones == 0),
  769.      but we can't do this since we can change the number of drones.
  770.    */
  771.  
  772.   if (first_time_p)
  773.   {
  774.     open_gc_file (size, 0);
  775. #ifdef F_SETFD
  776.     /* Set the close on exec flag, the drones re-open it to get a
  777.        different file pointer so that all the processes can independently
  778.        lseek without clobbering each other.
  779.      */
  780.     (void) (fcntl (gc_file, F_SETFD, 1));
  781. #endif
  782.   }
  783.  
  784.   buffer_space = (n_gc_buffers
  785.           * (gc_total_buffer_size * (sizeof (SCHEME_OBJECT))));
  786.   shared_size =
  787.     (ALIGN_UP_TO_IO_PAGE (buffer_space
  788.               + (n_gc_buffers * (sizeof (struct buffer_info)))
  789.               + (n_gc_drones * (sizeof (struct drone_info)))
  790.               + (sizeof (long))
  791.               + (sizeof (long))
  792.               + (r_overlap * (sizeof (struct gc_queue_entry)))
  793.               + (w_overlap * (sizeof (struct gc_queue_entry)))
  794.               + IO_PAGE_SIZE));
  795.  
  796.   malloc_size = ((n_gc_drones == 0)
  797.          ? shared_size
  798.          : (first_time_p ? MALLOC_SPACE : 0));
  799.  
  800.   if (malloc_size > 0)
  801.   {
  802.     malloc_memory = ((char *) (malloc (malloc_size)));
  803.     if (malloc_memory == ((char *) NULL))
  804.     {
  805.       fprintf
  806.     (stderr,
  807.      "%s (sysV_initialize): Unable to allocate %d bytes (errno = %s).\n",
  808.      scheme_program_name, malloc_size, (error_name (errno)));
  809.       return (parameterization_termination (1, first_time_p));
  810.     }
  811.   }
  812.  
  813.   if (n_gc_drones == 0)
  814.     shared_memory = ((char *) (ALIGN_UP_TO_IO_PAGE (malloc_memory)));
  815.   else
  816.   {
  817.     if ((shmid = (shmget (IPC_PRIVATE, shared_size, 0600))) == -1)
  818.     {
  819.       fprintf
  820.     (stderr,
  821.      "%s (sysV_initialize): shmget (-, %d, -) failed (errno = %s).\n",
  822.      scheme_program_name, shared_size, (error_name (errno)));
  823.       fprintf (stderr,
  824.            "\tUnable to allocate shared memory for drone processes.\n");
  825.       return (parameterization_termination (0, first_time_p));
  826.     }
  827.     shared_memory = (shmat (shmid, ATTACH_POINT, 0));
  828.     if (shared_memory == ((char *) -1))
  829.     {
  830.       int saved_errno = errno;
  831.  
  832.       (void) (shmctl (shmid, IPC_RMID, 0));
  833.       shmid = -1;
  834.       fprintf
  835.     (stderr,
  836.      "%s (sysV_initialize): shmat (%d, 0x%lx, 0) failed. (errno = %s).\n",
  837.      scheme_program_name, shmid, shared_size, (error_name (saved_errno)));
  838.       fprintf (stderr,
  839.            "\tUnable to attach shared memory for drone processes.\n");
  840.       return (parameterization_termination (0, first_time_p));
  841.     }
  842.     signal (SIGCONT, continue_running);
  843.   }
  844.  
  845.   if (!(ALIGNED_TO_IO_PAGE_P (shared_memory)))
  846.   {
  847.     fprintf (stderr,
  848.          "%s (sysV_initialize): buffer space is not aligned properly.\n",
  849.          scheme_program_name);
  850.     fprintf (stderr,
  851.          "\taddress = 0x%lx; IO_PAGE_SIZE = 0x%lx.\n",
  852.          ((long) shared_memory), ((long) IO_PAGE_SIZE));
  853.     return (parameterization_termination (0, first_time_p));
  854.   }
  855.  
  856.   if ((n_gc_drones != 0) && (malloc_size > 0)
  857.       && (malloc_memory != ((char *) NULL)))
  858.   {
  859.     free (malloc_memory);
  860.     malloc_memory = ((char *) NULL);
  861.   }
  862.  
  863.   gc_buffers = ((struct buffer_info *) (shared_memory + buffer_space));
  864.   gc_drones = ((struct drone_info *) (gc_buffers + n_gc_buffers));
  865.   drone_version = ((unsigned long *) (gc_drones + n_gc_drones));
  866.   wait_mask = (drone_version + 1);
  867.   gc_read_queue = ((struct gc_queue_entry *) (drone_version + 2));
  868.   gc_write_queue = (gc_read_queue + r_overlap);
  869.  
  870.   /* Initialize structures. */
  871.  
  872.   *wait_mask = ((unsigned long) 0);
  873.   gc_next_drone = 0;
  874.   gc_next_buffer = 0;
  875.  
  876.   drone_file_name = ((char *) drfnam);
  877.   if ((drfnam != ((char *) NULL)) && (drfnam[0] != SUB_DIRECTORY_DELIMITER))
  878.   {
  879.     CONST char * temp = (search_for_library_file (drfnam));
  880.  
  881.     if (temp != ((char *) NULL))
  882.     {
  883.       drone_file_name = temp;
  884.       if (drfnam != option_gc_drone)
  885.     free ((PTR) drfnam);
  886.     }
  887.   }
  888.  
  889.   for (bufptr = ((SCHEME_OBJECT *) shared_memory), cntr = 0,
  890.        buffer = gc_buffers;
  891.        (cntr < n_gc_buffers);
  892.        bufptr = buffer->end, cntr++, buffer++)
  893.   {
  894.     buffer->index = cntr;
  895.     buffer->state = buffer_idle;
  896.     buffer->position = -1;
  897.     buffer->bottom = ((PTR) bufptr);
  898.     buffer->top = ((PTR) (bufptr + gc_buffer_size));
  899.     buffer->end = ((PTR) (bufptr + gc_total_buffer_size));
  900.   }
  901.  
  902.   if (n_gc_drones == 0)
  903.     shared_memory = ((char *) -1);
  904.   else
  905.   {
  906.     struct gc_queue_entry * entry;
  907.     struct drone_info * drone;
  908.  
  909.     /* Make sure that SIGCONT is enabled. */
  910.     {
  911.       sigset_t mask;
  912.  
  913.       UX_sigemptyset (&mask);
  914.       UX_sigaddset ((&mask), SIGCONT);
  915.       UX_sigprocmask (SIG_UNBLOCK, (&mask), 0);
  916.     }
  917.  
  918.     for (cntr = 0, entry = gc_read_queue;
  919.      cntr < read_overlap;
  920.      cntr++, entry++)
  921.     {
  922.       entry->index = cntr;
  923.       entry->state = entry_idle;
  924.       entry->retry_count = 0;
  925.     }
  926.  
  927.     for (cntr = 0, entry = gc_write_queue;
  928.      cntr < write_overlap;
  929.      cntr++, entry++)
  930.     {
  931.       entry->index = cntr;
  932.       entry->state = entry_idle;
  933.       entry->retry_count = 0;
  934.     }
  935.  
  936.     for (cntr = 0, drone = gc_drones;
  937.      cntr < n_gc_drones;
  938.      cntr++, drone++)
  939.     {
  940.       drone->index = cntr;
  941.       drone->state = drone_not_ready;
  942.     }
  943.  
  944.     start_gc_drones (0, n_gc_drones, 0);
  945.     if (gc_drones->state != drone_idle)
  946.     {
  947.       fprintf (stderr,
  948.            "%s (sysV_initialize): Problems starting up the GC drones%s.\n",
  949.            scheme_program_name,
  950.            (((* drone_version) != ((unsigned long) DRONE_VERSION_NUMBER))
  951.         ? " (wrong drone version)"
  952.         : ""));
  953.       return (parameterization_termination (0, first_time_p));
  954.     }
  955.     drones_initialized_p = 1;
  956.   }
  957.   return (0);
  958. }
  959.  
  960. static void EXFUN (close_gc_file, (int));
  961.  
  962. static void
  963. DEFUN (sysV_shutdown, (final_time_p), int final_time_p)
  964. {
  965.   /* arg should be (n_gc_drones > 0), see sysV_initialize */
  966.   if (final_time_p)
  967.     close_gc_file (1);
  968.  
  969.   if (malloc_memory != ((char *) NULL))
  970.   {
  971.     free (malloc_memory);
  972.     malloc_memory = ((char *) NULL);    
  973.   }
  974.  
  975.   if ((n_gc_drones != 0) && (drones_initialized_p))
  976.   {
  977.     kill_all_gc_drones ();
  978.     drones_initialized_p = 0;
  979.   }
  980.  
  981.   if ((shared_memory != ((char *) -1)) && ((shmdt (shared_memory)) == -1))
  982.   {
  983.     fprintf (stderr, "\n%s (sysV_shutdown): shmdt failed.  errno = %s.\n",
  984.          scheme_program_name, (error_name (errno)));
  985.     fflush (stderr);
  986.   }
  987.   shared_memory = ((char *) -1);
  988.  
  989.   if ((shmid != -1)
  990.       && (shmctl (shmid, IPC_RMID, ((struct shmid_ds *) 0))) == -1)
  991.   {
  992.     fprintf (stderr, "\n%s (sysV_shutdown): shmctl failed.  errno = %s.\n",
  993.          scheme_program_name, (error_name (errno)));
  994.     fflush (stderr);
  995.   }
  996.   shmid = -1;
  997.  
  998.   return;
  999. }
  1000.  
  1001. static int
  1002. DEFUN (find_idle_drone, (wait_p), int wait_p)
  1003. {
  1004.   int drone_index, next_drone_index, count = 0;
  1005.   struct drone_info * drone;
  1006.  
  1007.   drone_index = gc_next_drone;
  1008.   while (1)
  1009.   {
  1010.     count += 1;
  1011.     do
  1012.     {
  1013.       next_drone_index = (drone_index + 1);
  1014.       if (next_drone_index >= n_gc_drones)
  1015.     next_drone_index = 0;
  1016.  
  1017.       drone = (gc_drones + drone_index);
  1018.       switch (drone->state)
  1019.       {
  1020.       case drone_idle:
  1021.     gc_next_drone = next_drone_index;
  1022.     return (drone_index);
  1023.  
  1024.       case drone_dead:
  1025.     start_gc_drones (drone_index, 1, 1);
  1026.     /* fall through, look at it on next pass. */
  1027.  
  1028.       default:
  1029.     break;        
  1030.       }
  1031.       drone_index = next_drone_index;
  1032.     } while (drone_index != gc_next_drone);
  1033.  
  1034.     /* All the drones are busy... */
  1035.  
  1036.     if (!wait_p)
  1037.     {
  1038.       STATISTICS_INCR (drone_request_failures);
  1039.       return (-1);
  1040.     }
  1041.  
  1042.     if (count == 10)
  1043.     {
  1044.       probe_all_gc_drones (0);
  1045.       count = 0;
  1046.     }
  1047.     else
  1048.     {
  1049.       /* Use -1 as the mask to awaken when any drone becomes idle. */
  1050.  
  1051.       sleep_awaiting_drones (default_sleep_period, ((unsigned long) -1));
  1052.       STATISTICS_INCR (drone_wait_cycles);
  1053.     }
  1054.   }
  1055. }
  1056.  
  1057. static void
  1058. DEFUN (abort_gc_drone, (drone), struct drone_info * drone)
  1059. {
  1060.   int restart_p = 0;
  1061.   sigset_t block_mask, signal_mask;
  1062.   
  1063.   UX_sigemptyset (&block_mask);
  1064.   UX_sigaddset ((&block_mask), SIGCONT);
  1065.   UX_sigprocmask (SIG_BLOCK, (&block_mask), (&signal_mask));
  1066.  
  1067.   *wait_mask = (((unsigned long) 1) << drone->index);
  1068.   if (drone->state != drone_idle)
  1069.   {
  1070.     if ((kill (drone->DRONE_PID, SIGQUIT)) == -1)
  1071.       restart_p = 1;
  1072.     else if (drone->state != drone_idle)
  1073.       UX_sigsuspend (&signal_mask);
  1074.   }
  1075.   *wait_mask = ((unsigned long) 0);
  1076.   UX_sigprocmask (SIG_SETMASK, (&signal_mask), 0);
  1077.   if (restart_p)
  1078.     start_gc_drones (drone->index, 1, 1);
  1079.   return;
  1080. }
  1081.  
  1082. static struct gc_queue_entry *
  1083. DEFUN (find_queue_entry, (queue, queue_size, position, drone_index),
  1084.        struct gc_queue_entry * queue AND int queue_size
  1085.        AND long position AND int drone_index)
  1086. {
  1087.   struct gc_queue_entry * entry; 
  1088.   int cntr;
  1089.  
  1090.   for (cntr = 0, entry = queue; cntr < queue_size; cntr++, entry++)
  1091.   {
  1092.     if ((entry->state != entry_idle)
  1093.     && (((entry->buffer)->position == position)
  1094.         || (entry->drone_index == drone_index)))
  1095.       return (entry);
  1096.   }
  1097.   return ((struct gc_queue_entry *) NULL);
  1098. }
  1099.  
  1100. enum allocate_request
  1101. {
  1102.   request_read,
  1103.   request_write,
  1104.   request_ready
  1105. };
  1106.  
  1107. static struct gc_queue_entry *
  1108. DEFUN (allocate_queue_entry, (queue, queue_size, position, request, mask),
  1109.        struct gc_queue_entry * queue AND int queue_size AND long position
  1110.        AND enum allocate_request request AND unsigned long * mask)
  1111. {
  1112.   struct gc_queue_entry * entry; 
  1113.   int cntr, queue_index, drone_index;
  1114.   unsigned long drone_mask;
  1115.  
  1116.   /* Examine all entries for duplicates, ergo no `break' */
  1117.  
  1118.   queue_index = -1;
  1119.   drone_mask = ((unsigned long) 0);
  1120.   for (cntr = 0, entry = queue; cntr < queue_size; cntr++, entry++)
  1121.   {
  1122.  
  1123.     if (entry->state == entry_idle)
  1124.       queue_index = cntr;
  1125.     else if ((entry->buffer)->position == position)
  1126.       return (entry);
  1127.     else if (entry->state == entry_error)
  1128.     {
  1129.       struct buffer_info * buffer = entry->buffer;
  1130.  
  1131.       entry->retry_count += 1;
  1132.       if (entry->retry_count <= MAX_OVERLAPPED_RETRIES)
  1133.       {
  1134.     if (request == request_write)
  1135.     {
  1136.       /* This was done when originally queued, but we are paranoid. */
  1137.       (void) (verify_write (buffer->position, buffer->size,
  1138.                 ((Boolean *) NULL)));
  1139.       do
  1140.         entry->drone_index = (find_idle_drone (1));
  1141.       while (!(invoke_gc_drone (entry, drone_writing, entry->buffer,
  1142.                     buffer->position, buffer->size)));
  1143.       STATISTICS_INCR (writes_retried);
  1144.     }
  1145.     else
  1146.     {
  1147.       entry->drone_index = (find_idle_drone (0));
  1148.       if ((entry->drone_index != -1)
  1149.           && (invoke_gc_drone (entry, drone_reading, entry->buffer,
  1150.                    buffer->position, buffer->size)))
  1151.         STATISTICS_INCR (pre_reads_retried);
  1152.       else
  1153.         STATISTICS_INCR (pre_reads_not_retried);
  1154.     }
  1155.       }
  1156.       else if (request == request_write)
  1157.       {
  1158.     STATISTICS_INCR (writes_not_deferred);
  1159.     write_data (((char *) (buffer->bottom)),
  1160.             buffer->position, buffer->size,
  1161.             "a queued buffer", ((Boolean *) NULL));
  1162.     buffer->state = buffer_idle;
  1163.     entry->state = entry_idle;
  1164.     entry->retry_count = 0;
  1165.     queue_index = cntr;
  1166.       }
  1167.       else
  1168.     /* If pre-reading, it will be taken care of later. */
  1169.     STATISTICS_INCR (pre_reads_deferred);
  1170.     }
  1171.     else if ((drone_index = (entry->drone_index)) != -1)
  1172.       drone_mask |= (((unsigned long) 1) << drone_index);
  1173.   }
  1174.  
  1175.   if (queue_index == -1)
  1176.   {
  1177.     probe_all_gc_drones (0);
  1178.     if (mask != ((unsigned long *) NULL))
  1179.       (* mask) = drone_mask;
  1180.     return ((struct gc_queue_entry *) NULL);
  1181.   }
  1182.  
  1183.   entry = (queue + queue_index);
  1184.   entry->buffer = ((struct buffer_info *) NULL);
  1185.   return (entry);
  1186. }
  1187.  
  1188. static struct buffer_info *
  1189. DEFUN_VOID (find_idle_buffer)
  1190. {
  1191.   int next_buffer, new_next_buffer;
  1192.   struct buffer_info *buffer;
  1193.  
  1194.   next_buffer = gc_next_buffer;
  1195.   do
  1196.   {
  1197.     new_next_buffer = (next_buffer + 1);
  1198.     if (new_next_buffer >= n_gc_buffers)
  1199.       new_next_buffer = 0;
  1200.     buffer = (gc_buffers + next_buffer);
  1201.     if (buffer->state == buffer_idle)
  1202.     {
  1203.       gc_next_buffer = new_next_buffer;
  1204.       return (buffer);
  1205.     }
  1206.     next_buffer = new_next_buffer;
  1207.   } while (next_buffer != gc_next_buffer);
  1208.  
  1209.   fprintf (stderr, "\n%s (find_idle_buffer): All buffers are in use!\n",
  1210.        scheme_program_name);
  1211.   fflush (stderr);
  1212.   Microcode_Termination (TERM_GC_OUT_OF_SPACE);
  1213.   /*NOTREACHED*/
  1214. }
  1215.  
  1216. static struct buffer_info * 
  1217. DEFUN (find_ready_buffer, (position, size), long position AND long size)
  1218. {
  1219.   int next_buffer, new_next_buffer;
  1220.   struct buffer_info *buffer;
  1221.  
  1222.   next_buffer = gc_next_buffer;
  1223.   do
  1224.   {
  1225.     new_next_buffer = (next_buffer + 1);
  1226.     if (new_next_buffer >= n_gc_buffers)
  1227.       new_next_buffer = 0;
  1228.     buffer = (gc_buffers + next_buffer);
  1229.     if ((buffer->state == buffer_idle) /* && (buffer->size == size) */
  1230.     && (buffer->position == position))
  1231.     {
  1232.       gc_next_buffer = new_next_buffer;
  1233.       return (buffer);
  1234.     }
  1235.     next_buffer = new_next_buffer;
  1236.   } while (next_buffer != gc_next_buffer);
  1237.   return ((struct buffer_info *) NULL);
  1238. }
  1239.  
  1240. static struct buffer_info *
  1241. DEFUN_VOID (get_gc_buffer)
  1242. {
  1243.   struct buffer_info * buffer;
  1244.  
  1245.   buffer = (find_idle_buffer ());
  1246.   buffer->state = buffer_busy;
  1247.   return (buffer);
  1248. }
  1249.  
  1250. static struct buffer_info *
  1251. DEFUN (read_buffer, (posn, size, noise),
  1252.        long posn AND long size AND char * noise)
  1253. {
  1254.   struct gc_queue_entry * entry;
  1255.   struct buffer_info * buffer;
  1256.  
  1257.   if ((read_overlap > 0)
  1258.       && ((entry = (find_queue_entry (gc_read_queue, read_overlap, posn, -2)))
  1259.       != ((struct gc_queue_entry *) NULL))
  1260.       && ((buffer = entry->buffer) != ((struct buffer_info *) NULL)))
  1261.   {
  1262.     switch (buffer->state)
  1263.     {
  1264.       default:
  1265.     fprintf (stderr, "\n%s (read_buffer %s): invalid state.\n",
  1266.          scheme_program_name, noise);
  1267.     fprintf (stderr, "\tindex = %d; state = %d; position = 0x%lx.\n",
  1268.          buffer->index, buffer->state, posn);
  1269.     fflush (stderr);
  1270.     /* fall through */
  1271.  
  1272.       case buffer_read_error:
  1273.     /* Try synchronously, and complain then if the condition persists. */
  1274.     break;
  1275.  
  1276.       case buffer_being_read:
  1277.       {
  1278.     int count;
  1279.     struct drone_info * drone = (gc_drones + entry->drone_index);
  1280.  
  1281.     for (count = 1; (buffer->state == buffer_being_read) ; count++)
  1282.     {
  1283.       if (count == 10)
  1284.       {
  1285.         if (probe_gc_drone (drone))
  1286.           count = 0;
  1287.         else
  1288.         {
  1289.           start_gc_drones (drone->index, 1, 1);
  1290.           goto buffer_failed;
  1291.         }
  1292.       }
  1293.       else
  1294.         sleep_awaiting_drones (default_sleep_period,
  1295.                    (((unsigned long) 1) << drone->index));
  1296.       STATISTICS_INCR (read_wait_cycles);
  1297.     }
  1298.  
  1299.     if (buffer->state != buffer_ready)
  1300.     {
  1301. buffer_failed:
  1302.       entry->state = entry_idle;
  1303.       entry->retry_count = 0;
  1304.       buffer->state = buffer_idle;
  1305.       buffer->position = -1;
  1306.       STATISTICS_INCR (reads_overlapped_aborted);
  1307.       break;
  1308.     }
  1309.     STATISTICS_INCR (reads_pending);
  1310.     goto buffer_available;
  1311.       }
  1312.  
  1313.       case buffer_queued:
  1314.     STATISTICS_INCR (reads_queued);
  1315.     goto buffer_available;
  1316.  
  1317.       case buffer_ready:
  1318.     STATISTICS_INCR (reads_ready);
  1319.  
  1320. buffer_available:
  1321.     /* This should check size, but they are all the same. */
  1322.     entry->state = entry_idle;
  1323.     entry->retry_count = 0;
  1324.     buffer->state = buffer_busy;
  1325.     STATISTICS_INCR (reads_overlapped);
  1326.     return (buffer);
  1327.     }
  1328.   }
  1329.   else if ((write_overlap > 0)
  1330.        && ((entry = (find_queue_entry (gc_write_queue, write_overlap,
  1331.                        posn, -2)))
  1332.            != ((struct gc_queue_entry *) NULL)))
  1333.   {
  1334.     int index;
  1335.  
  1336.     /* This should check size, but they are all the same. */
  1337.  
  1338.     entry->state = entry_idle;
  1339.     entry->retry_count = 0;
  1340.     buffer = entry->buffer;
  1341.     index = entry->drone_index;
  1342.     if (index != -1)
  1343.       abort_gc_drone (gc_drones + index);
  1344.     buffer->state = buffer_busy;
  1345.     STATISTICS_INCR (reads_found_in_write_queue);
  1346.     return (buffer);
  1347.   }
  1348.   else if ((buffer = (find_ready_buffer (posn, size)))
  1349.        != ((struct buffer_info *) NULL))
  1350.   {
  1351.     /* This should check size, but they are all the same. */
  1352.  
  1353.     buffer->state = buffer_busy;
  1354.     STATISTICS_INCR (reads_found_ready);
  1355.     return (buffer);
  1356.   }
  1357.  
  1358.   /* (read_overlap == 0) or not pre-read. */
  1359.   {
  1360.     buffer = (find_idle_buffer ());
  1361.  
  1362.     load_data (posn, ((char *) buffer->bottom), size,
  1363.            noise, ((Boolean *) NULL));
  1364.     buffer->state = buffer_busy;
  1365.     STATISTICS_INCR (reads_not_overlapped);
  1366.     return (buffer);
  1367.   }
  1368. }
  1369.  
  1370. static void
  1371. DEFUN (write_buffer, (buffer, position, size, success, noise),
  1372.        struct buffer_info * buffer AND long position
  1373.        AND long size AND Boolean * success AND char * noise)
  1374. {
  1375.   if ((write_overlap > 0) && ((verify_write (position, size, success)) != -1))
  1376.   {
  1377.     unsigned long drone_mask;
  1378.     struct gc_queue_entry * entry =
  1379.       (allocate_queue_entry (gc_write_queue, write_overlap,
  1380.                  position, request_write, (& drone_mask)));
  1381.  
  1382.     if (entry == ((struct gc_queue_entry *) NULL))
  1383.     {
  1384.       STATISTICS_INCR (writes_pending);
  1385.       do
  1386.       {
  1387.     sleep_awaiting_drones (default_sleep_period, drone_mask);
  1388.     entry =
  1389.       (allocate_queue_entry (gc_write_queue, write_overlap,
  1390.                  position, request_write, (& drone_mask)));
  1391.     STATISTICS_INCR (write_wait_cycles);
  1392.       } while (entry == ((struct gc_queue_entry *) NULL));
  1393.     }
  1394.     else if (entry->buffer != NULL)
  1395.     {
  1396.       int index = entry->drone_index;
  1397.       struct buffer_info * old_buffer;
  1398.  
  1399.       if (index != -1)
  1400.     abort_gc_drone (gc_drones + index);
  1401.       old_buffer = entry->buffer;
  1402.       old_buffer->state = buffer_idle;
  1403.       entry->buffer = buffer;
  1404.       fprintf (stderr,
  1405.            "\n%s (write_buffer %s): duplicate write at 0x%lx.\n",
  1406.            scheme_program_name, noise, position);
  1407.       fflush (stderr);
  1408.     }
  1409.     do
  1410.       entry->drone_index = (find_idle_drone (1));
  1411.     while (!(invoke_gc_drone (entry, drone_writing, buffer, position, size)));
  1412.     STATISTICS_INCR (writes_overlapped);
  1413.     return;
  1414.   }
  1415.  
  1416.   STATISTICS_INCR (writes_not_overlapped);
  1417.   write_data (((char *) buffer->bottom), position, size, noise, success);
  1418.   buffer->state = buffer_idle;
  1419.   return;
  1420. }
  1421.  
  1422. static void
  1423. DEFUN (enqueue_buffer, (entry, buffer, position, size, state),
  1424.        struct gc_queue_entry * entry AND struct buffer_info * buffer
  1425.        AND long position AND long size AND enum buffer_state state)
  1426. {
  1427.   buffer->state = state;
  1428.   buffer->position = position;
  1429.   buffer->size = size;
  1430.   entry->buffer = buffer;
  1431.   entry->drone_index = -1;
  1432.   entry->state = entry_busy;
  1433.   return;
  1434. }
  1435.  
  1436. static void
  1437. DEFUN (enqueue_ready_buffer, (buffer, position, size),
  1438.        struct buffer_info * buffer AND long position AND long size)
  1439. {
  1440.   struct gc_queue_entry * entry;
  1441.  
  1442.   if ((read_overlap == 0)
  1443.       || ((entry = (allocate_queue_entry (gc_read_queue, read_overlap,
  1444.                       position, request_ready,
  1445.                       ((unsigned long *) NULL))))
  1446.       == ((struct gc_queue_entry *) NULL)))
  1447.   {
  1448.     write_buffer (buffer, position, size, ((char *) NULL), "a ready buffer");
  1449.     STATISTICS_INCR (ready_buffers_not_enqueued);
  1450.     return;
  1451.   }
  1452.   if (entry->buffer != NULL)  
  1453.   {
  1454.     int index = entry->drone_index;
  1455.     struct buffer_info * old_buffer = entry->buffer;
  1456.  
  1457.     if (index != -1)
  1458.       abort_gc_drone (gc_drones + index);
  1459.     old_buffer->state = buffer_idle;
  1460.     fprintf (stderr,
  1461.          "\n%s (enqueue_ready_buffer): Duplicate pre-read at 0x%lx.\n",
  1462.          scheme_program_name, old_buffer->position);
  1463.     fflush (stderr);
  1464.   }
  1465.   enqueue_buffer (entry, buffer, position, size, buffer_queued);
  1466.   STATISTICS_INCR (ready_buffers_enqueued);
  1467.   return;
  1468. }
  1469.  
  1470. static void
  1471. DEFUN (abort_pre_read, (position), long position)
  1472. {
  1473.   int index;
  1474.   struct gc_queue_entry * entry;
  1475.   struct buffer_info * buffer;
  1476.   
  1477.   entry = (find_queue_entry (gc_read_queue, read_overlap, position, -2));
  1478.   if (entry == ((struct gc_queue_entry *) NULL))
  1479.     return;
  1480.   buffer = entry->buffer;
  1481.   if (buffer->state == buffer_queued)
  1482.   {
  1483.     entry->state = entry_idle;
  1484.     entry->retry_count = 0;
  1485.     write_buffer (buffer, buffer->position, buffer->size,
  1486.           ((Boolean *) NULL), "a queued buffer");
  1487.     STATISTICS_INCR (pre_reads_requeued_as_writes);
  1488.     return;
  1489.   }
  1490.   index = entry->drone_index;
  1491.   if (index != -1)
  1492.     abort_gc_drone (gc_drones + index);
  1493.   buffer->state = buffer_idle;
  1494.   buffer->position = -1;
  1495.   entry->state = entry_idle;
  1496.   entry->retry_count = 0;
  1497.   STATISTICS_INCR (pre_reads_aborted);
  1498.   return;
  1499. }
  1500.  
  1501. static int
  1502. DEFUN (pre_read_buffer, (position, size), long position AND long size)
  1503. {
  1504.   struct gc_queue_entry * rentry, * wentry;
  1505.   struct buffer_info * buffer;
  1506.  
  1507.   if (read_overlap <= 0)
  1508.     return (0);
  1509.  
  1510.   /* Do this first, to guarantee that we can insert it in the queue.
  1511.      Otherwise there is no point in aborting a write, etc.
  1512.      It is not really allocated until enqueue_buffer or invoke_gc_drone.
  1513.    */
  1514.  
  1515.   rentry = (allocate_queue_entry (gc_read_queue, read_overlap,
  1516.                   position, request_read,
  1517.                   ((unsigned long *) NULL)));
  1518.   if (rentry == ((struct gc_queue_entry *) NULL))
  1519.   {
  1520.     STATISTICS_INCR (pre_reads_ignored);
  1521.     return (0);
  1522.   }
  1523.   else if (rentry->buffer != NULL)
  1524.     /* Already being pre-read */
  1525.     return (1);
  1526.  
  1527.   if ((write_overlap > 0)
  1528.       && ((wentry = (find_queue_entry (gc_write_queue, write_overlap,
  1529.                        position, -2)))
  1530.       != ((struct gc_queue_entry *) NULL)))
  1531.   {
  1532.     int index = wentry->drone_index;
  1533.  
  1534.     buffer = wentry->buffer;
  1535.     if (index != -1)
  1536.       abort_gc_drone (gc_drones + index);
  1537.     wentry->state = entry_idle;
  1538.     wentry->retry_count = 0;
  1539.     enqueue_buffer (rentry, buffer, position, size, buffer_queued);
  1540.     STATISTICS_INCR (pre_reads_found_in_write_queue);
  1541.     return (1);
  1542.   }
  1543.   else if ((buffer = (find_ready_buffer (position, size)))
  1544.        != ((struct buffer_info *) NULL))
  1545.   {
  1546.     enqueue_buffer (rentry, buffer, position, size, buffer_ready);
  1547.     STATISTICS_INCR (pre_reads_found_ready);
  1548.     return (1);
  1549.   }
  1550.  
  1551.   if (((rentry->drone_index = (find_idle_drone (0))) == -1)
  1552.       || (!(invoke_gc_drone (rentry, drone_reading, (find_idle_buffer ()),
  1553.                  position, size))))
  1554.   {
  1555.     STATISTICS_INCR (pre_reads_not_started);
  1556.     return (0);
  1557.   }
  1558.   STATISTICS_INCR (pre_reads_started);
  1559.   return (1);
  1560. }
  1561.  
  1562. static void
  1563. DEFUN (handle_drone_death, (drone), struct drone_info * drone)
  1564. {
  1565.   struct buffer_info * buffer;
  1566.   struct gc_queue_entry * entry;
  1567.  
  1568.   STATISTICS_INCR (drones_found_dead);
  1569.   if ((entry = (find_queue_entry (gc_write_queue, write_overlap,
  1570.                   -1, drone->index)))
  1571.       != ((struct gc_queue_entry *) NULL))
  1572.   {
  1573.     buffer = entry->buffer;
  1574.     entry->state = entry_idle;
  1575.     entry->retry_count = 0;
  1576.     if (buffer->state != buffer_idle)
  1577.     {
  1578.       write_buffer (buffer, buffer->position, buffer->size,
  1579.             ((Boolean *) NULL), "a queued buffer whose drone died");
  1580.       STATISTICS_INCR (writes_restarted);
  1581.     }
  1582.   }
  1583.   else if ((entry = (find_queue_entry (gc_read_queue, read_overlap,
  1584.                        -1, drone->index)))
  1585.        != ((struct gc_queue_entry *) NULL))
  1586.   {
  1587.     buffer = entry->buffer;
  1588.     if (buffer->state != buffer_ready)
  1589.     {
  1590.       entry->state = entry_idle;
  1591.       entry->retry_count = 0;
  1592.       buffer->state = buffer_idle;
  1593.       STATISTICS_INCR (pre_reads_restarted);
  1594.       (void) (pre_read_buffer (buffer->position, buffer->size));
  1595.     }
  1596.   }
  1597.   return;
  1598. }
  1599.  
  1600. static void
  1601. DEFUN (await_io_completion, (start_p), int start_p)
  1602. {
  1603.   int cntr;
  1604.   struct buffer_info * buffer;
  1605.   struct gc_queue_entry * entry;
  1606.  
  1607.   if (n_gc_drones != 0)
  1608.     probe_all_gc_drones (1);
  1609.   if (start_p)
  1610.   {
  1611.     for (cntr = 0, buffer = gc_buffers; cntr < n_gc_buffers; cntr++, buffer++)
  1612.     {
  1613.       buffer->state = buffer_idle;
  1614.       buffer->position = -1;
  1615.     }
  1616.     for (cntr = 0, entry = gc_read_queue; cntr < read_overlap; cntr++, entry++)
  1617.       entry->state = entry_idle;
  1618.     for (cntr = 0, entry = gc_write_queue; cntr < write_overlap;
  1619.      cntr++, entry++)
  1620.       entry->state = entry_idle;
  1621.   }
  1622.   return;
  1623. }
  1624.  
  1625. #define CAN_RECONFIGURE_GC_BUFFERS    1
  1626.  
  1627. #define GC_BUFFER_ALLOCATION(space)    0
  1628.  
  1629. #define INITIALIZE_GC_BUFFERS(ft, start, size, ro, wo, gcd)        \
  1630.  sysV_initialize (ft, size, ro, wo, gcd)
  1631.  
  1632. #define RE_INITIALIZE_GC_BUFFERS(ft, start, size, ro, wo, gcd)        \
  1633.  sysV_initialize (ft, size, ro, wo, gcd)
  1634.  
  1635. #define BUFFER_SHUTDOWN(lt)        sysV_shutdown (lt)
  1636.  
  1637. #define INITIALIZE_IO()            await_io_completion (1)
  1638. #define AWAIT_IO_COMPLETION()        await_io_completion (0)
  1639.  
  1640. #define INITIAL_SCAN_BUFFER()        free_buffer        /* NOP */
  1641. #define INITIAL_FREE_BUFFER()        get_gc_buffer ()
  1642. #define OTHER_BUFFER(buffer)        get_gc_buffer ()
  1643.  
  1644. #define GC_BUFFER_BOTTOM(buffer)     ((SCHEME_OBJECT *) buffer->bottom)
  1645. #define GC_BUFFER_TOP(buffer)         ((SCHEME_OBJECT *) buffer->top)
  1646.  
  1647. #define READ_BUFFER            read_buffer
  1648. #define DUMP_BUFFER            write_buffer
  1649. #define PRE_READ_BUFFER            pre_read_buffer
  1650. #define ABORT_PRE_READ            abort_pre_read
  1651. #define ENQUEUE_READY_BUFFER        enqueue_ready_buffer
  1652.  
  1653. #define LOAD_BUFFER(buffer, position, size, noise)            \
  1654.   buffer = (read_buffer (position, size, noise))
  1655.  
  1656. #endif /* HAVE_SYSV_SHARED_MEMORY */
  1657.  
  1658.  
  1659.  
  1660. #ifndef GC_BUFFER_ALLOCATION
  1661.  
  1662. static struct buffer_info
  1663.   * gc_disk_buffer_1,
  1664.   * gc_disk_buffer_2;
  1665.  
  1666. #define CAN_RECONFIGURE_GC_BUFFERS    0
  1667.  
  1668. #define GC_BUFFER_ALLOCATION(space)    space
  1669.  
  1670. #define INITIALIZE_GC_BUFFERS(ft, start, size, ro, wo, gcd)        \
  1671. do {                                    \
  1672.   SCHEME_OBJECT * ptr = (start);                    \
  1673.                                     \
  1674.   gc_disk_buffer_1 = ((struct buffer_info *) ptr);            \
  1675.   gc_disk_buffer_2 = ((struct buffer_info *)                \
  1676.               (ptr + gc_total_buffer_size));            \
  1677.   open_gc_file (size, 1);                        \
  1678. } while (0)
  1679.  
  1680. #define BUFFER_SHUTDOWN(lt)    close_gc_file (lt)
  1681.  
  1682. #define INITIALIZE_IO()        do { } while (0)
  1683. #define AWAIT_IO_COMPLETION()    do { } while (0)
  1684.  
  1685. #define INITIAL_FREE_BUFFER()    gc_disk_buffer_1
  1686. #define INITIAL_SCAN_BUFFER()    OTHER_BUFFER(free_buffer)
  1687.  
  1688. /* (gc_disk_buffer_1 - (gc_disk_buffer_2 - (buffer))) does not work
  1689.    because scan_buffer is not initialized until after scanning
  1690.    constant space.
  1691. */
  1692.  
  1693. #define OTHER_BUFFER(buffer)    (((buffer) == gc_disk_buffer_1)        \
  1694.                  ? gc_disk_buffer_2            \
  1695.                  : gc_disk_buffer_1)
  1696.  
  1697. #define GC_BUFFER_BOTTOM(buffer) ((SCHEME_OBJECT *) (buffer))
  1698. #define GC_BUFFER_TOP(buffer) (((SCHEME_OBJECT *) (buffer)) + gc_buffer_size)
  1699.  
  1700. static int
  1701. DEFUN (catastrophic_failure, (name), char * name)
  1702. {
  1703.   fprintf (stderr,
  1704.        "\n%s: Procedure %s should never be called!\n",
  1705.        scheme_program_name, name);
  1706.   fflush (stderr);
  1707.   Microcode_Termination (TERM_EXIT);
  1708.   /*NOTREACHED*/
  1709. }
  1710.  
  1711. #define GCDIE(m)            catastrophic_failure (m)
  1712.  
  1713. #define RE_INITIALIZE_GC_BUFFERS(f,s,z,r,w,g)                \
  1714.                     GCDIE ("RE_INITIALIZE_GC_BUFFERS")
  1715. #define READ_BUFFER(p,s,n)        GCDIE ("read_buffer")
  1716. #define PRE_READ_BUFFER(p,s)        GCDIE ("pre_read_buffer")
  1717. #define ABORT_PRE_READ(p)        GCDIE ("abort_pre_read")
  1718. #define ENQUEUE_READY_BUFFER(b,p,s)    GCDIE ("enqueue_ready_buffer")
  1719.  
  1720. #define LOAD_BUFFER(buffer, position, size, noise)            \
  1721.   load_data (position, ((char *) buffer), size, noise, ((Boolean *) NULL))
  1722.  
  1723. #define DUMP_BUFFER(buffer, position, size, successp, noise)        \
  1724.   write_data (((char *) buffer), position, size, noise, successp)
  1725.  
  1726. #endif /* GC_BUFFER_ALLOCATION */
  1727.  
  1728. static int
  1729. DEFUN (next_exponent_of_two, (value), int value)
  1730. {
  1731.   unsigned int power;
  1732.   int exponent;
  1733.  
  1734.   if (value < 0)
  1735.     return (0);
  1736.   
  1737.   for (power = 1, exponent = 0;
  1738.        power < ((unsigned int) value);
  1739.        power = (power << 1), exponent += 1)
  1740.     ;
  1741.   return (exponent);
  1742. }
  1743.  
  1744. /* Hacking the gc file */
  1745.  
  1746. static int
  1747.   saved_gc_file = -1,
  1748.   saved_read_overlap,
  1749.   saved_write_overlap;
  1750.  
  1751. static long
  1752.   saved_start_position,
  1753.   saved_end_position;
  1754.  
  1755. int
  1756. DEFUN (swap_gc_file, (fid), int fid)
  1757. {
  1758.   /* Do not use overlapped I/O for fasdump because the drone processes
  1759.      will continue writing to the same old file!
  1760.    */
  1761.   saved_gc_file = gc_file;
  1762.   saved_read_overlap = read_overlap;
  1763.   saved_write_overlap = write_overlap;
  1764.   saved_start_position = gc_file_start_position;
  1765.   saved_end_position = gc_file_end_position;
  1766.   gc_file = fid;
  1767.   read_overlap = 0;
  1768.   write_overlap = 0;
  1769.   gc_file_start_position = 0L;
  1770.   gc_file_end_position = (saved_heap_size * (sizeof (SCHEME_OBJECT)));
  1771.   return (saved_gc_file);
  1772. }
  1773.  
  1774. void
  1775. DEFUN_VOID (restore_gc_file)
  1776. {
  1777.   gc_file = saved_gc_file;
  1778.   read_overlap = saved_read_overlap;
  1779.   write_overlap = saved_write_overlap;
  1780.   gc_file_start_position = saved_start_position;
  1781.   gc_file_end_position = saved_end_position;
  1782.   saved_gc_file = -1;
  1783.   return;
  1784. }
  1785.  
  1786. static void
  1787. DEFUN (close_gc_file, (unlink_p), int unlink_p)
  1788. {
  1789. #ifdef F_ULOCK
  1790.   if (gc_file != -1)
  1791.   {
  1792.     (void) (lseek (gc_file, gc_file_start_position, SEEK_SET));
  1793.     (void) (lockf (gc_file, F_ULOCK,
  1794.            (gc_file_end_position - gc_file_start_position)));
  1795.   }
  1796. #endif
  1797.   if ((gc_file != -1) && ((close (gc_file)) == -1))
  1798.   {
  1799.     fprintf (stderr,
  1800.          "\n%s (close_gc_file): error: GC file = \"%s\"; errno = %s.\n",
  1801.          scheme_program_name, gc_file_name, (error_name (errno)));
  1802.     fflush (stderr);
  1803.   }
  1804.   gc_file = -1;
  1805.   if (!keep_gc_file_p && unlink_p)
  1806.     unlink (gc_file_name);
  1807.   gc_file_name = ((char *) NULL);
  1808.   keep_gc_file_p = 0;
  1809.   return;
  1810. }
  1811.  
  1812. static void
  1813. DEFUN (termination_open_gc_file, (operation, extra),
  1814.        CONST char * operation AND CONST char * extra)
  1815. {
  1816.   if ((operation != ((char *) NULL)) && (*operation != '\0'))
  1817.     fprintf
  1818.       (stderr,
  1819.        "%s (open_gc_file): %s (\"%s\") failed, (errno = %s).\n",
  1820.        scheme_program_name, operation, gc_file_name, (error_name (errno)));
  1821.   if ((extra != ((char *) NULL)) && (*extra != '\0'))
  1822.     fprintf (stderr, "\t%s.\n", extra);
  1823.   fflush (stderr);
  1824.   termination_init_error ();
  1825.   /*NOTREACHED*/
  1826. }
  1827.  
  1828. extern char * EXFUN (mktemp, (char *));
  1829. extern long EXFUN (lseek, (int, long, int));
  1830.  
  1831. static void
  1832. DEFUN (open_gc_file, (size, unlink_p),
  1833.        long size AND int unlink_p)
  1834. {
  1835.   struct stat file_info;
  1836.   int position, flags;
  1837.   Boolean exists_p;
  1838.  
  1839.   gc_file_name = &gc_file_name_buffer[0];
  1840.   if (option_gc_file[0] == SUB_DIRECTORY_DELIMITER)
  1841.     strcpy (gc_file_name, option_gc_file);
  1842.   else
  1843.   {
  1844.     position = (strlen (option_gc_directory));
  1845.     if ((position == 0) || 
  1846.     (option_gc_directory[position - 1] != SUB_DIRECTORY_DELIMITER))
  1847.       sprintf (gc_file_name, "%s%c%s", 
  1848.            option_gc_directory, SUB_DIRECTORY_DELIMITER, option_gc_file);
  1849.     else
  1850.       sprintf (gc_file_name, "%s%s", option_gc_directory, option_gc_file);
  1851.   }
  1852.  
  1853.   /* mktemp supposedly only clobbers Xs from the end.
  1854.      If the string does not end in Xs, it is untouched. 
  1855.      This presents a quoting problem, but...
  1856.      Well, it seems to clobber the string if there are no Xs.
  1857.    */
  1858.  
  1859. #if TRUE
  1860.   position = (strlen (option_gc_file));
  1861.   if ((position >= 6)
  1862.       && ((strncmp ((option_gc_file + (position - 6)), "XXXXXX", 6)) == 0))
  1863. #endif
  1864.     (void) (mktemp (gc_file_name));
  1865.  
  1866.   flags = GC_FILE_FLAGS;
  1867.   gc_file_start_position = (ALIGN_UP_TO_IO_PAGE (option_gc_start_position));
  1868.   gc_file_end_position = option_gc_end_position;
  1869.   if (gc_file_end_position == -1)
  1870.     gc_file_end_position = (gc_file_start_position + size);
  1871.   gc_file_end_position = (ALIGN_DOWN_TO_IO_PAGE (gc_file_end_position));
  1872.   if (gc_file_end_position < gc_file_start_position)
  1873.   {
  1874.     fprintf (stderr, "%s (open_gc_file): file bounds are inconsistent.\n",
  1875.          scheme_program_name);
  1876.     fprintf (stderr, "\trequested start = 0x%lx;\taligned start = 0x%lx.\n",
  1877.          option_gc_start_position, gc_file_start_position);
  1878.     fprintf (stderr, "\trequested end   = 0x%lx;\taligned end   = 0x%lx.\n",
  1879.          option_gc_end_position, gc_file_end_position);
  1880.     termination_open_gc_file (((char *) NULL), ((char *) NULL));
  1881.   }
  1882.  
  1883.   if ((stat (gc_file_name, &file_info)) == -1)
  1884.   {
  1885.     exists_p = false;
  1886.     can_dump_directly_p = true;
  1887.     flags |= O_EXCL;
  1888.   }
  1889.   else
  1890.   {
  1891.     /* If it is S_IFCHR, it should determine the IO block
  1892.        size and make sure that it will work.
  1893.        I don't know how to do that.
  1894.        ustat(2) will do that for a mounted file system,
  1895.        but obviously, if a raw device file is used,
  1896.        there better not be a file system on the device or partition.
  1897.        Does st_blksize give the correct value? -- Apparently not.
  1898.        */
  1899.  
  1900.     exists_p = true;
  1901.     if ((file_info.st_mode & S_IFMT) == S_IFCHR)
  1902.       can_dump_directly_p = false;
  1903.  
  1904.     else if (((file_info.st_mode & S_IFMT) != S_IFREG)
  1905.          && ((file_info.st_mode & S_IFMT) != S_IFBLK))
  1906.     {
  1907.       fprintf (stderr,
  1908.            "%s (open_gc_file): file \"%s\" has unknown/bad type 0x%x.\n",
  1909.            scheme_program_name, gc_file_name,
  1910.            ((int) (file_info.st_mode & S_IFMT)));
  1911.       fprintf
  1912.     (stderr,
  1913.      "\tKnown types: S_IFREG (0x%x), S_IFBLK (0x%x), S_IFCHR (0x%x).\n",
  1914.      S_IFREG, S_IFBLK, S_IFCHR);
  1915.       termination_open_gc_file (((char *) NULL), ((char *) NULL));
  1916.     }
  1917.     else
  1918.       can_dump_directly_p = true;
  1919.   }
  1920.  
  1921.   gc_file = (open (gc_file_name, flags, GC_FILE_MASK));
  1922.   if (gc_file == -1)
  1923.     termination_open_gc_file ("open", ((char *) NULL));
  1924.  
  1925.   keep_gc_file_p = (exists_p || option_gc_keep);
  1926.  
  1927. #ifdef UNLINK_BEFORE_CLOSE
  1928.   if (!keep_gc_file_p && unlink_p)
  1929.   {
  1930.     (void) (unlink (gc_file_name));
  1931.   }
  1932. #endif  
  1933.  
  1934. #ifdef HAVE_PREALLOC
  1935.   if (!exists_p)
  1936.   {
  1937.     extern int EXFUN (prealloc, (int, off_t));
  1938.  
  1939.     (void) (prealloc (gc_file, ((unsigned int) gc_file_end_position)));
  1940.   }
  1941. #endif /* HAVE_PREALLOC */
  1942.  
  1943. #ifdef F_TLOCK
  1944.   if (exists_p)
  1945.   {
  1946.     extern int EXFUN (locfk, (int, int, long));
  1947.  
  1948.     if ((lseek (gc_file, gc_file_start_position, SEEK_SET)) == -1)
  1949.       termination_open_gc_file ("lseek", ((char *) NULL));
  1950.  
  1951.     if ((lockf (gc_file, F_TLOCK, size)) == -1)
  1952.       termination_open_gc_file
  1953.     ("lockf",
  1954.      "The GC file is probably being used by another process");
  1955.   }
  1956. #endif /* F_TLOCK */
  1957.  
  1958.   gc_file_current_position = -1;    /* Unknown position */
  1959.  
  1960.   /* Determine whether it is a seekable file. */
  1961.  
  1962.   if (exists_p && ((file_info.st_mode & S_IFMT) == S_IFCHR))
  1963.   {
  1964.     int flags;
  1965.     Boolean ignore;
  1966.     static char message[] = "This is a test message to the GC file.\n";
  1967.     char * buffer;
  1968.   
  1969.     buffer = ((char *) aligned_heap);
  1970.     strcpy (buffer, &message[0]);
  1971.     strncpy ((buffer + ((sizeof (message)) - 1)),
  1972.          buffer,
  1973.          (IO_PAGE_SIZE - (sizeof (message))));
  1974.     (* (buffer + (IO_PAGE_SIZE - 1))) = '\n';
  1975.  
  1976. #if defined(F_GETFL) && defined(F_SETFL) && defined(O_NONBLOCK)
  1977.     if ((flags = (fcntl (gc_file, F_GETFL, 0))) != -1)
  1978.       (void) (fcntl (gc_file, F_SETFL, (flags | O_NONBLOCK)));
  1979. #endif
  1980.  
  1981.     write_data (buffer,
  1982.         (gc_file_start_position + ((long) IO_PAGE_SIZE)),
  1983.         ((long) IO_PAGE_SIZE),
  1984.         "a test buffer (1)",
  1985.         &ignore);
  1986.     load_data (gc_file_start_position,
  1987.            (buffer + IO_PAGE_SIZE),
  1988.            ((long) (2 * IO_PAGE_SIZE)),
  1989.            "a test buffer (2)",
  1990.            &ignore);
  1991.     if ((strncmp (buffer, (buffer + (2 * IO_PAGE_SIZE)), IO_PAGE_SIZE)) != 0)
  1992.     {
  1993.       fprintf (stderr,
  1994.            "\n%s (open_gc_file): \"%s\" is not a seek-able device.\n",
  1995.            scheme_program_name, gc_file_name);
  1996.       termination_open_gc_file (((char *) NULL), ((char *) NULL));
  1997.     }
  1998. #if defined(F_GETFL) && defined(F_SETFL) && defined(O_NONBLOCK)
  1999.     if (flags != -1)
  2000.       (void) (fcntl (gc_file, F_SETFL, (flags | O_NONBLOCK)));
  2001. #endif
  2002.   }
  2003.   return;
  2004. }
  2005.  
  2006. void
  2007. DEFUN (Clear_Memory, (heap_size, stack_size, constant_space_size),
  2008.        int heap_size
  2009.        AND int stack_size
  2010.        AND int constant_space_size)
  2011. {
  2012.   GC_Reserve = 4500;
  2013.   GC_Space_Needed = 0;
  2014.   Heap_Top = (Heap_Bottom + heap_size);
  2015.   SET_MEMTOP (Heap_Top - GC_Reserve);
  2016.   Free = Heap_Bottom;
  2017.   Constant_Top = (Constant_Space + constant_space_size);
  2018.   Initialize_Stack ();
  2019.   Free_Constant = Constant_Space;
  2020.   SET_CONSTANT_TOP ();
  2021.   return;
  2022. }
  2023.  
  2024. void
  2025. DEFUN_VOID (Reset_Memory)
  2026. {
  2027.   BUFFER_SHUTDOWN (1);
  2028.   return;
  2029. }
  2030.  
  2031. #define BLOCK_TO_IO_SIZE(size)                        \
  2032.   ((ALIGN_UP_TO_IO_PAGE ((size) * (sizeof (SCHEME_OBJECT))))        \
  2033.    / (sizeof (SCHEME_OBJECT)))
  2034.  
  2035. static int
  2036. DEFUN (set_gc_buffer_sizes, (new_buffer_shift), unsigned long new_buffer_shift)
  2037. {
  2038.   unsigned long
  2039.     new_buffer_size, new_buffer_bytes, new_buffer_byte_shift,
  2040.     new_buffer_overlap_bytes, new_extra_buffer_size;
  2041.   
  2042.   new_buffer_size = (1L << new_buffer_shift);
  2043.   new_buffer_bytes = (new_buffer_size * (sizeof (SCHEME_OBJECT)));
  2044.   if (!ALIGNED_TO_IO_PAGE_P (new_buffer_bytes))
  2045.   {
  2046.     fprintf (stderr,
  2047.          "%s (Setup_Memory): improper new_buffer_size.\n",
  2048.          scheme_program_name);
  2049.     fprintf (stderr, "\tIO_PAGE_SIZE   = 0x%lx bytes.\n",
  2050.          ((long) IO_PAGE_SIZE));
  2051.     fprintf (stderr, "\tgc_buffer_size = 0x%lx bytes = 0x%lx objects.\n",
  2052.          new_buffer_bytes, new_buffer_size);
  2053.     fprintf (stderr, "\tIO_PAGE_SIZE should divide gc_buffer_size.\n");
  2054.     return (-1);
  2055.   }
  2056.  
  2057.   new_buffer_byte_shift = (next_exponent_of_two (new_buffer_bytes));
  2058.   if ((1L << new_buffer_byte_shift) != new_buffer_bytes)
  2059.   {
  2060.     fprintf
  2061.       (stderr,
  2062.        "%s (Setup_Memory): gc_buffer_bytes (= 0x%lx) is not a power of 2.\n",
  2063.        scheme_program_name, new_buffer_bytes);
  2064.     return (-1);
  2065.   }
  2066.  
  2067.   new_buffer_overlap_bytes = IO_PAGE_SIZE;
  2068.   new_extra_buffer_size
  2069.     = (new_buffer_overlap_bytes / (sizeof (SCHEME_OBJECT)));
  2070.   if ((new_extra_buffer_size * (sizeof (SCHEME_OBJECT)))
  2071.       != new_buffer_overlap_bytes)
  2072.   {
  2073.     fprintf (stderr, " %s (Setup_Memory): improper IO_PAGE_SIZE.\n",
  2074.          scheme_program_name);
  2075.     fprintf (stderr,
  2076.          "\tIO_PAGE_SIZE = 0x%lx; (sizeof (SCHEME_OBJECT)) = 0x%lx.\n",
  2077.          ((long) IO_PAGE_SIZE), ((long) (sizeof (SCHEME_OBJECT))));
  2078.     fprintf (stderr,
  2079.          "\t(sizeof (SCHEME_OBJECT)) should divide IO_PAGE_SIZE.\n");
  2080.     return (-1);
  2081.   }
  2082.  
  2083.   gc_buffer_shift = new_buffer_shift;
  2084.   gc_buffer_size = new_buffer_size;
  2085.   gc_buffer_bytes = new_buffer_bytes;
  2086.   gc_buffer_mask = (gc_buffer_size - 1);
  2087.   gc_buffer_byte_shift = new_buffer_byte_shift;
  2088.   gc_buffer_overlap_bytes = new_buffer_overlap_bytes;
  2089.   gc_extra_buffer_size = new_extra_buffer_size;
  2090.   gc_buffer_remainder_bytes = (gc_buffer_bytes - gc_buffer_overlap_bytes);
  2091.   gc_total_buffer_size = (gc_buffer_size + gc_extra_buffer_size);
  2092.   return (0);
  2093. }
  2094.  
  2095. void
  2096. DEFUN (Setup_Memory, (heap_size, stack_size, constant_space_size),
  2097.        int heap_size
  2098.        AND int stack_size
  2099.        AND int constant_space_size)
  2100. {
  2101.   SCHEME_OBJECT test_value;
  2102.   int real_stack_size, fudge_space;
  2103.  
  2104.   /* Consistency check 1 */
  2105.   if (heap_size == 0)
  2106.   {
  2107.     fprintf (stderr,
  2108.          "%s (Setup_Memory): Configuration won't hold initial data.\n",
  2109.          scheme_program_name);
  2110.     fflush (stderr);
  2111.     termination_init_error ();
  2112.     /*NOTREACHED*/
  2113.   }
  2114.  
  2115.   real_stack_size = (Stack_Allocation_Size (stack_size));
  2116.  
  2117.   /* add log(1024)/log(2) to exponent */
  2118.   if ((set_gc_buffer_sizes (10 + (next_exponent_of_two
  2119.                    (option_gc_window_size))))
  2120.       != 0)
  2121.     parameterization_termination (1, 1);
  2122.  
  2123.   /* Use multiples of IO_PAGE_SIZE. */
  2124.  
  2125.   fudge_space = ((BLOCK_TO_IO_SIZE (HEAP_BUFFER_SPACE + 1))
  2126.          + (IO_PAGE_SIZE / (sizeof (SCHEME_OBJECT))));
  2127.   heap_size = (BLOCK_TO_IO_SIZE (heap_size));
  2128.   constant_space_size = (BLOCK_TO_IO_SIZE (constant_space_size));
  2129.   real_stack_size = (BLOCK_TO_IO_SIZE (real_stack_size));
  2130.  
  2131.   /* Allocate. */
  2132.  
  2133.   ALLOCATE_HEAP_SPACE (fudge_space + heap_size
  2134.                + constant_space_size + real_stack_size
  2135.                + (GC_BUFFER_ALLOCATION (2 * gc_total_buffer_size)));
  2136.  
  2137.   /* Consistency check 2 */
  2138.   if (Heap == NULL)
  2139.   {
  2140.     fprintf (stderr,
  2141.          "%s (Setup_Memory): Not enough memory for this configuration.\n",
  2142.          scheme_program_name);
  2143.     fflush (stderr);
  2144.     termination_init_error ();
  2145.     /*NOTREACHED*/
  2146.   }
  2147.  
  2148.   Heap += HEAP_BUFFER_SPACE;
  2149.   Heap = ((SCHEME_OBJECT *) (ALIGN_UP_TO_IO_PAGE (Heap)));
  2150.   aligned_heap = Heap;
  2151.   Constant_Space = (Heap + heap_size);
  2152.  
  2153.   /*
  2154.      The two GC buffers are not included in the valid Scheme memory.
  2155.   */
  2156.  
  2157.   Highest_Allocated_Address = ((Constant_Space + constant_space_size
  2158.                 + real_stack_size) - 1);
  2159.  
  2160.   /* Consistency check 3 */
  2161.   test_value =
  2162.     (MAKE_POINTER_OBJECT (LAST_TYPE_CODE, Highest_Allocated_Address));
  2163.  
  2164.   if (((OBJECT_TYPE (test_value)) != LAST_TYPE_CODE) ||
  2165.       ((OBJECT_ADDRESS (test_value)) != Highest_Allocated_Address))
  2166.   {
  2167.     fprintf (stderr,
  2168.          "\
  2169. %s (Setup_Memory): Largest address does not fit in datum field of object.\n",
  2170.          scheme_program_name);
  2171.     fprintf (stderr,
  2172.          "\
  2173. \tAllocate less space or re-configure without HEAP_IN_LOW_MEMORY.\n");
  2174.     fflush (stderr);
  2175.     termination_init_error ();
  2176.     /*NOTREACHED*/
  2177.   }
  2178.  
  2179.   /* This does not use INITIAL_ALIGN_HEAP because it would
  2180.      make Heap point to the previous GC_BUFFER frame.
  2181.      INITIAL_ALIGN_HEAP should have its phase changed so that it would
  2182.      be a NOP below, and constant space should use it too.
  2183.    */     
  2184.  
  2185.   ALIGN_FLOAT (Heap);
  2186.   ALIGN_FLOAT (Constant_Space);
  2187.   heap_size = (Constant_Space - Heap);
  2188.   constant_space_size = ((Highest_Allocated_Address - Constant_Space)
  2189.              - real_stack_size);
  2190.   saved_heap_size = ((long) heap_size);
  2191.  
  2192.   Heap_Bottom = Heap;
  2193.   Clear_Memory (heap_size, stack_size, constant_space_size);
  2194.  
  2195.   INITIALIZE_GC_BUFFERS (1,
  2196.              (Highest_Allocated_Address + 1),
  2197.              (heap_size * (sizeof (SCHEME_OBJECT))),
  2198.              option_gc_read_overlap,
  2199.              option_gc_write_overlap,
  2200.              option_gc_drone);
  2201.   return;
  2202. }
  2203.  
  2204. /* Utilities for the GC proper. */ 
  2205.  
  2206. static void
  2207. DEFUN (enqueue_free_buffer, (success), Boolean * success)
  2208. {
  2209.   int diff;
  2210.  
  2211.   diff = ((free_position - pre_read_position) >> gc_buffer_byte_shift);
  2212.   if (diff >= read_overlap)
  2213.     DUMP_BUFFER (free_buffer, free_position, gc_buffer_bytes,
  2214.          success, "the free buffer");
  2215.   else
  2216.   {
  2217.     ENQUEUE_READY_BUFFER (free_buffer, free_position, gc_buffer_bytes);
  2218.     read_queue_bitmask |= (1L << diff);
  2219.   }
  2220.   return;
  2221. }
  2222.  
  2223. static void
  2224. DEFUN_VOID (schedule_pre_reads)
  2225. {
  2226.   int cntr;
  2227.   long position;
  2228.   unsigned long bit;
  2229.  
  2230.   if (pre_read_position == scan_position)
  2231.   {
  2232.     read_queue_bitmask = (read_queue_bitmask >> 1);
  2233.     pre_read_position += gc_buffer_bytes;
  2234.   }
  2235.   for (cntr = 0, bit = 1L, position = pre_read_position;
  2236.        ((cntr < read_overlap) && (position < free_position));
  2237.        cntr++, bit = (bit << 1), position += gc_buffer_bytes)
  2238.   {
  2239.     if ((read_queue_bitmask & bit) != bit)
  2240.       if (PRE_READ_BUFFER (position, gc_buffer_bytes))
  2241.     read_queue_bitmask |= bit;
  2242.   }
  2243.   return;
  2244. }
  2245.  
  2246. static void
  2247. DEFUN_VOID (abort_pre_reads)
  2248. {
  2249.   while (scan_position > pre_read_position)
  2250.   {
  2251.     ABORT_PRE_READ (pre_read_position);
  2252.     pre_read_position += gc_buffer_bytes;
  2253.     read_queue_bitmask = (read_queue_bitmask >> 1);
  2254.   }
  2255.   schedule_pre_reads ();
  2256.   return;
  2257. }
  2258.  
  2259. static void
  2260. DEFUN (reload_scan_buffer, (skip), int skip)
  2261. {
  2262.  
  2263.   scan_position += (skip << gc_buffer_byte_shift);
  2264.   virtual_scan_pointer += (skip << gc_buffer_shift);
  2265.  
  2266.   if ((read_overlap > 0) && (scan_position > pre_read_position))
  2267.     abort_pre_reads ();
  2268.  
  2269.   if (scan_position == free_position)
  2270.   {
  2271.     pre_read_position = (free_position + gc_buffer_bytes);
  2272.     read_queue_bitmask = 0L;
  2273.     scan_buffer = free_buffer;
  2274.     scan_buffer_bottom = free_buffer_bottom;
  2275.     scan_buffer_top = free_buffer_top;
  2276.     return;
  2277.   }
  2278.   LOAD_BUFFER (scan_buffer, scan_position,
  2279.            gc_buffer_bytes, "the scan buffer");
  2280.   scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
  2281.   scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
  2282.   *scan_buffer_top = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
  2283.   
  2284.   if (read_overlap > 0)
  2285.     schedule_pre_reads ();
  2286.   return;
  2287. }
  2288.  
  2289. SCHEME_OBJECT *
  2290. DEFUN (dump_and_reload_scan_buffer, (number_to_skip, success),
  2291.        long number_to_skip AND Boolean * success)
  2292. {
  2293.   DUMP_BUFFER (scan_buffer, scan_position, gc_buffer_bytes,
  2294.         success, "the scan buffer");
  2295.   reload_scan_buffer (1 + number_to_skip);
  2296.   return (scan_buffer_bottom);
  2297. }
  2298.  
  2299. SCHEME_OBJECT *
  2300. DEFUN (dump_and_reset_free_buffer, (overflow, success),
  2301.        fast long overflow AND Boolean * success)
  2302. {
  2303.   Boolean buffer_overlap_p, same_buffer_p;
  2304.   fast SCHEME_OBJECT *into, *from;
  2305.  
  2306.   from = free_buffer_top;
  2307.   buffer_overlap_p = extension_overlap_p;
  2308.   same_buffer_p = (scan_buffer == free_buffer);
  2309.  
  2310.   if (read_overlap > 0)
  2311.   {
  2312.     if (buffer_overlap_p)
  2313.     {
  2314.       extension_overlap_p = false;
  2315.       next_scan_buffer = free_buffer;
  2316.     }
  2317.     else if (!same_buffer_p)
  2318.       enqueue_free_buffer (success);
  2319.   }
  2320.   else if (!same_buffer_p)
  2321.     DUMP_BUFFER (free_buffer, free_position, gc_buffer_bytes,
  2322.          success, "the free buffer");
  2323.  
  2324.   /* Otherwise there is no need to dump now, it will be dumped
  2325.      when scan is dumped.  Note that the next buffer may be dumped
  2326.      before this one, but there should be no problem lseeking past the
  2327.      end of file.
  2328.    */
  2329.  
  2330.   free_position += gc_buffer_bytes;
  2331.   free_buffer = (OTHER_BUFFER (scan_buffer));
  2332.   free_buffer_bottom = (GC_BUFFER_BOTTOM (free_buffer));
  2333.   free_buffer_top = (GC_BUFFER_TOP (free_buffer));
  2334.  
  2335.   for (into = free_buffer_bottom; --overflow >= 0; )
  2336.     *into++ = *from++;
  2337.  
  2338.   if (same_buffer_p && !buffer_overlap_p)
  2339.     *scan_buffer_top =
  2340.       (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
  2341.   return (into);
  2342. }
  2343.  
  2344. /* These utilities are needed when pointers fall accross window boundaries.
  2345.  
  2346.    Between both they effectively do a dump_and_reload_scan_buffer, in two
  2347.    stages.
  2348. */
  2349.  
  2350. void
  2351. DEFUN (extend_scan_buffer, (to_where, current_free),
  2352.        fast char * to_where AND SCHEME_OBJECT * current_free)
  2353. {
  2354.   fast char * source, * dest;
  2355.   long new_scan_position = (scan_position + gc_buffer_bytes);
  2356.  
  2357.   /* Is there buffer overlap?, i.e. is the next bufferful the one cached
  2358.      in the free pointer window?
  2359.    */
  2360.  
  2361.   scan_buffer_extended_p = true;
  2362.   dest = ((char *) scan_buffer_top);
  2363.   extension_overlap_length = (to_where - dest);
  2364.   extension_overlap_p = (new_scan_position == free_position);
  2365.  
  2366.   if (extension_overlap_p)
  2367.   {
  2368.     long temp;
  2369.  
  2370.     source = ((char *) free_buffer_bottom);
  2371.     temp = (((char *) current_free) - source);
  2372.     if (temp < extension_overlap_length)
  2373.     {
  2374.       /* This should only happen when Scan and Free are very close. */
  2375.       extension_overlap_length = temp;
  2376.     }
  2377.   }
  2378.   else if (read_overlap == 0)
  2379.   {
  2380.     load_data (new_scan_position, dest, gc_buffer_overlap_bytes,
  2381.            "the next scan buffer", ((Boolean *) NULL));
  2382.     return;
  2383.   }
  2384.   else
  2385.   {
  2386.     LOAD_BUFFER (next_scan_buffer, new_scan_position,
  2387.          gc_buffer_bytes, "the next scan buffer");
  2388.     source = ((char *) (GC_BUFFER_BOTTOM (next_scan_buffer)));
  2389.   }
  2390.  
  2391.   while (dest < to_where)
  2392.     *dest++ = *source++;
  2393.   return;
  2394. }
  2395.  
  2396. char *
  2397. DEFUN (end_scan_buffer_extension, (to_relocate), char * to_relocate)
  2398. {
  2399.   char * result;
  2400.   if (extension_overlap_p)
  2401.   {
  2402.     /* There was overlap between the scan buffer and the free buffer,
  2403.        there may no longer be, but dump_and_reload_scan_buffer will
  2404.        get us the correct next buffer.
  2405.        The old scan buffer may be written, but the while loop below
  2406.        will read storage contiguous to it (in the buffer extension).
  2407.      */
  2408.     SCHEME_OBJECT old, new;
  2409.     fast char * source, * dest, * limit;
  2410.  
  2411.     extension_overlap_p = false;
  2412.     source = ((char *) scan_buffer_top);
  2413.     old = (* ((SCHEME_OBJECT *) source));
  2414.     limit = (source + extension_overlap_length);
  2415.     dest = ((char *) (dump_and_reload_scan_buffer (0, ((Boolean *) NULL))));
  2416.     /* The following is only necesary if we are reusing the scan buffer. */
  2417.     new = (* scan_buffer_top);
  2418.     (* ((SCHEME_OBJECT *) source)) = old;
  2419.     result = (dest + (to_relocate - source));
  2420.     while (source < limit)
  2421.       *dest++ = *source++;
  2422.     (* scan_buffer_top) = new;
  2423.   }
  2424.   else if (next_scan_buffer == ((struct buffer_info *) NULL))
  2425.   {
  2426.     /* There was no buffer overlap and no read overlap */
  2427.  
  2428.     fast SCHEME_OBJECT * source, * dest, * limit;
  2429.  
  2430.     source = scan_buffer_top;
  2431.     limit = (source + gc_extra_buffer_size);
  2432.  
  2433.     DUMP_BUFFER (scan_buffer, scan_position, gc_buffer_bytes,
  2434.          ((Boolean *) NULL), "the scan buffer");
  2435.     scan_position += gc_buffer_bytes;
  2436.     virtual_scan_pointer += gc_buffer_size;
  2437.  
  2438.     scan_buffer = (OTHER_BUFFER (free_buffer));
  2439.     scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
  2440.     scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
  2441.  
  2442.     dest = scan_buffer_bottom;
  2443.     result = (((char *) dest) + (to_relocate - ((char *) source)));
  2444.  
  2445.     while (source < limit)
  2446.       *dest++ = *source++;
  2447.  
  2448.     if (gc_buffer_remainder_bytes != 0)
  2449.       load_data ((scan_position + gc_buffer_overlap_bytes),
  2450.          ((char *) dest), gc_buffer_remainder_bytes,
  2451.          "the scan buffer", ((Boolean *) NULL));
  2452.  
  2453.     (* scan_buffer_top) =
  2454.       (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
  2455.   }
  2456.   else
  2457.   {
  2458.     /* There is overlap with the next bufferful (not the free bufferful). */
  2459.  
  2460.     fast char * source, * dest, * limit;
  2461.  
  2462.     source = ((char *) scan_buffer_top);
  2463.     limit = (source + extension_overlap_length);
  2464.     dest = ((char *) (GC_BUFFER_BOTTOM (next_scan_buffer)));
  2465.     result = (dest + (to_relocate - source));
  2466.  
  2467.     while (source < limit)
  2468.       *dest++ = *source++;
  2469.     
  2470.     DUMP_BUFFER (scan_buffer, scan_position, gc_buffer_bytes,
  2471.          ((Boolean *) NULL), "the scan buffer");
  2472.     scan_position += gc_buffer_bytes;
  2473.     virtual_scan_pointer += gc_buffer_size;
  2474.  
  2475.     scan_buffer = next_scan_buffer;
  2476.     next_scan_buffer = NULL;
  2477.     scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
  2478.     scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
  2479.     (* scan_buffer_top) =
  2480.       (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
  2481.     schedule_pre_reads ();
  2482.   }
  2483.   scan_buffer_extended_p = false; 
  2484.   return (result);
  2485. }
  2486.  
  2487. /* This is used to avoid unnecessary copying when copying a large
  2488.    non-marked area.
  2489.  */
  2490.  
  2491. SCHEME_OBJECT *
  2492. DEFUN (dump_free_directly, (from, nbuffers, success),
  2493.        fast SCHEME_OBJECT * from
  2494.        AND fast long nbuffers
  2495.        AND Boolean * success)
  2496. {
  2497.   if (((read_overlap + write_overlap) == 0)
  2498.       && (can_dump_directly_p || (ALIGNED_TO_IO_PAGE_P (from))))
  2499.   {
  2500.     long byte_length = (nbuffers << gc_buffer_byte_shift);
  2501.  
  2502.     write_data (((char *) from), free_position, byte_length,
  2503.         "free buffers", success);
  2504.     free_position += byte_length;
  2505.   }
  2506.   else
  2507.   {
  2508.     /* This assumes that the free buffer has no valid data, so it can be
  2509.        used as scratch.
  2510.        This code is executed when there is I/O overlap, or when the
  2511.        data is not aligned to be written to a raw (character) device.
  2512.      */
  2513.  
  2514.     while ((--nbuffers) >= 0)
  2515.     {
  2516.       fast SCHEME_OBJECT * to, * bufend;
  2517.  
  2518.       for (to = free_buffer_bottom, bufend = free_buffer_top; to != bufend; )
  2519.     *to++ = *from++;
  2520.  
  2521.       (void) (dump_and_reset_free_buffer (0, success));
  2522.     }
  2523.   }
  2524.   return (free_buffer_bottom);
  2525. }
  2526.  
  2527. #ifndef START_TRANSPORT_HOOK
  2528. #define START_TRANSPORT_HOOK()        do { } while (0)
  2529. #endif
  2530.  
  2531. #ifndef END_TRANSPORT_HOOK
  2532. #define END_TRANSPORT_HOOK()        do { } while (0)
  2533. #endif
  2534.  
  2535. #ifndef END_WEAK_UPDATE_HOOK
  2536. #define END_WEAK_UPDATE_HOOK()        do { } while (0)
  2537. #endif
  2538.  
  2539. #ifndef START_RELOAD_HOOK
  2540. #define START_RELOAD_HOOK()        do { } while (0)
  2541. #endif
  2542.  
  2543. #ifndef END_GC_HOOK
  2544. #define END_GC_HOOK()            do { } while (0)
  2545. #endif
  2546.  
  2547. /* This hacks the scan buffer also so that Scan is always below
  2548.    scan_buffer_top until the scan buffer is initialized.
  2549.    Various parts of the garbage collector depend on scan_buffer_top
  2550.    having an aligned value.
  2551. */
  2552.  
  2553. SCHEME_OBJECT *
  2554. DEFUN_VOID (initialize_free_buffer)
  2555. {
  2556.   STATISTICS_CLEAR ();
  2557.   START_TRANSPORT_HOOK ();
  2558.   read_queue_bitmask = 0L;
  2559.   pre_read_position = gc_file_start_position;
  2560.   free_position = gc_file_start_position;
  2561.   INITIALIZE_IO ();
  2562.   free_buffer = (INITIAL_FREE_BUFFER ());
  2563.   free_buffer_bottom = (GC_BUFFER_BOTTOM (free_buffer));
  2564.   free_buffer_top = (GC_BUFFER_TOP (free_buffer));
  2565.   virtual_scan_pointer = NULL;
  2566.   scan_position = -1L;
  2567.   scan_buffer = NULL;
  2568.   scan_buffer_bottom = NULL;
  2569.   scan_buffer_top = (Highest_Allocated_Address + 2);
  2570.   /* Force first write to do an lseek. */
  2571.   gc_file_current_position = -1;
  2572.   next_scan_buffer = NULL;
  2573.   scan_buffer_extended_p = false;
  2574.   extension_overlap_p = false;
  2575.   extension_overlap_length = 0;
  2576.   return (free_buffer_bottom);
  2577. }
  2578.  
  2579. SCHEME_OBJECT *
  2580. DEFUN (initialize_scan_buffer, (block_start), SCHEME_OBJECT * block_start)
  2581. {
  2582.   virtual_scan_base = block_start;
  2583.   virtual_scan_pointer = virtual_scan_base;
  2584.   scan_position = gc_file_start_position;
  2585.   scan_buffer = (INITIAL_SCAN_BUFFER ());
  2586.   scan_buffer_bottom = (GC_BUFFER_BOTTOM (scan_buffer));
  2587.   scan_buffer_top = (GC_BUFFER_TOP (scan_buffer));
  2588.   reload_scan_buffer (0);
  2589.   return (scan_buffer_bottom);
  2590. }
  2591.  
  2592. void
  2593. DEFUN (end_transport, (success), Boolean * success)
  2594. {
  2595.   DUMP_BUFFER (scan_buffer, scan_position, gc_buffer_bytes,
  2596.            success, "the final scan buffer");
  2597.   scan_position += gc_buffer_bytes;
  2598.   virtual_scan_pointer += gc_buffer_size;
  2599.   free_position = scan_position;
  2600.   END_TRANSPORT_HOOK ();
  2601.   STATISTICS_PRINT (2, "after transport");
  2602.   return;
  2603. }
  2604.  
  2605. void
  2606. DEFUN (final_reload, (to, length, noise),
  2607.        SCHEME_OBJECT * to AND unsigned long length AND char * noise)
  2608. {
  2609.   unsigned long byte_length;
  2610.  
  2611.   byte_length = (ALIGN_UP_TO_IO_PAGE (length * (sizeof (SCHEME_OBJECT))));
  2612.   END_WEAK_UPDATE_HOOK ();
  2613.   AWAIT_IO_COMPLETION ();
  2614.   START_RELOAD_HOOK ();
  2615.   load_data (gc_file_start_position, ((char *) to), byte_length,
  2616.          noise, ((Boolean *) NULL));
  2617.   END_GC_HOOK ();
  2618.   STATISTICS_PRINT (1, "after final reload");
  2619.   return;
  2620. }
  2621.  
  2622. static int
  2623.   weak_buffer_pre_read_count;
  2624.  
  2625. static long
  2626.   weak_pair_buffer_position;
  2627.  
  2628. static struct buffer_info
  2629.   * weak_pair_buffer;
  2630.  
  2631. static SCHEME_OBJECT
  2632.   weak_pair_break;
  2633.  
  2634. /* This procedure is not very smart.
  2635.  
  2636.    It does not attempt to figure out whether the position being
  2637.    requested is already being pre-read, nor does it look further down
  2638.    the weak chain list for duplicate positions, to avoid early writes.
  2639.  
  2640.    On the other hand, pre_read_buffer will ignore the request if it is
  2641.    a duplicate, and will abort a pending write if a read for the same
  2642.    position is requested.
  2643.  */   
  2644.  
  2645. static void
  2646. DEFUN_VOID (pre_read_weak_pair_buffers)
  2647. {
  2648.   SCHEME_OBJECT next, * pair_addr, * obj_addr;
  2649.   long position, last_position;
  2650.  
  2651.   last_position = -1;
  2652.   next = weak_pair_break;
  2653.   while (next != EMPTY_LIST)
  2654.   {
  2655.     pair_addr = (OBJECT_ADDRESS (next));
  2656.     obj_addr = (OBJECT_ADDRESS (*pair_addr++));
  2657.     if (! (obj_addr >= Constant_Space))
  2658.     {
  2659.       position = (obj_addr - aligned_heap);
  2660.       position = (position >> gc_buffer_shift);
  2661.       position = (position << gc_buffer_byte_shift);
  2662.       position += gc_file_start_position;
  2663.  
  2664.       if ((position != last_position)
  2665.       && (position != weak_pair_buffer_position))
  2666.       {
  2667.     last_position = position;
  2668.     if ((weak_buffer_pre_read_count >= read_overlap)
  2669.         || (!(PRE_READ_BUFFER (position, gc_buffer_bytes))))
  2670.       break;
  2671.     weak_buffer_pre_read_count += 1;
  2672.       }
  2673.     }
  2674.     next = (OBJECT_NEW_TYPE (TC_NULL, (*pair_addr)));
  2675.   }
  2676.   weak_pair_break = next;
  2677.   return;
  2678. }
  2679.  
  2680. /* The following code depends on being called in between copying objects,
  2681.    so that the "free" pointer points to the middle of the free buffer,
  2682.    and thus the overlap area at the end of the free buffer is available
  2683.    as temporary storage.  In addition, because we have not yet moved free,
  2684.    next_scan_buffer has not been set even if we are in the middle of a
  2685.    scan buffer extension.
  2686.  */
  2687.  
  2688. SCHEME_OBJECT
  2689. DEFUN (read_newspace_address, (addr), SCHEME_OBJECT * addr)
  2690. {
  2691.   unsigned long position, offset;
  2692.   SCHEME_OBJECT result;
  2693.  
  2694.   if ((addr >= Constant_Space) && (addr < Free_Constant))
  2695.     return (* addr);
  2696.  
  2697.   position = (addr - virtual_scan_base);
  2698.   offset = (position & gc_buffer_mask);
  2699.   position = (position >> gc_buffer_shift);
  2700.   position = (position << gc_buffer_byte_shift);
  2701.   position += gc_file_start_position;
  2702.  
  2703.   if (position > free_position)
  2704.   {
  2705.     fprintf (stderr,
  2706.          "\n%s (read_newspace_address): Reading outside of GC window!\n",
  2707.          scheme_program_name);
  2708.     fprintf (stderr, "\t         addr = 0x%lx;\t     position = 0x%lx.\n",
  2709.          addr, position);
  2710.     fprintf (stderr, "\tscan_position = 0x%lx;\tfree_position = 0x%lx.\n",
  2711.          scan_position, free_position);
  2712.     fflush (stderr);
  2713.     Microcode_Termination (TERM_EXIT);
  2714.     /*NOTREACHED*/    
  2715.   }
  2716.   if (position == scan_position)
  2717.     result = (* (scan_buffer_bottom + offset));
  2718.   else if (position == free_position)
  2719.     result = (* (free_buffer_bottom + offset));
  2720.   else if ((position == (scan_position + gc_buffer_bytes))
  2721.        && scan_buffer_extended_p
  2722.        && ((read_overlap != 0) || (offset < gc_extra_buffer_size)))
  2723.   {
  2724.     /* Note: we need not worry about the state of extension_overlap_p,
  2725.        because if there is overlap between the scan extension and the free
  2726.        buffer, then (position == free_position) would be true,
  2727.        and that case has already been taken care of.
  2728.      */
  2729.        
  2730.     result = ((read_overlap == 0)
  2731.           ? (* (scan_buffer_top + offset))
  2732.           : (* ((GC_BUFFER_BOTTOM (next_scan_buffer)) + offset)));
  2733.   }
  2734.   else if ((read_overlap <= 0) || (position > pre_read_position))
  2735.   {
  2736.     unsigned long position2;
  2737.  
  2738.     position = (((char *) addr) - ((char *) virtual_scan_base));
  2739.     position2 = (ALIGN_DOWN_TO_IO_PAGE (position));
  2740.     offset = (position - position2);
  2741.     position2 += gc_file_start_position;
  2742.     
  2743.     load_data (position2,
  2744.            ((char *) free_buffer_top),
  2745.            IO_PAGE_SIZE,
  2746.            "a buffer for read_newspace_address",
  2747.            ((Boolean *) NULL));
  2748.     result = (* ((SCHEME_OBJECT *) (((char *) free_buffer_top) + offset)));
  2749.   }
  2750.   else
  2751.   {
  2752.     /* The buffer is pre-read or in the process of being pre-read.
  2753.        Force completion of the read, fetch the location,
  2754.        and re-queue the buffer as ready.
  2755.      */
  2756.  
  2757.     LOAD_BUFFER (next_scan_buffer, position, gc_buffer_bytes,
  2758.          "a buffer for read_newspace_address");
  2759.     result = ((GC_BUFFER_BOTTOM (next_scan_buffer)) [offset]);
  2760.     ENQUEUE_READY_BUFFER (next_scan_buffer, position, gc_buffer_bytes);
  2761.     next_scan_buffer = ((struct buffer_info *) NULL);
  2762.   }
  2763.   return (result);
  2764. }
  2765.  
  2766. static void
  2767. DEFUN (initialize_new_space_buffer, (chain), SCHEME_OBJECT chain)
  2768. {
  2769.   if (read_overlap == 0)
  2770.   {
  2771.     weak_pair_break = EMPTY_LIST;
  2772.     weak_pair_buffer = (INITIAL_FREE_BUFFER ());
  2773.     weak_pair_buffer_position = -1;
  2774.   }
  2775.   else
  2776.   {
  2777.     weak_pair_break = chain;
  2778.     weak_pair_buffer = ((struct buffer_info *) NULL);
  2779.     weak_pair_buffer_position = -1;
  2780.     weak_buffer_pre_read_count = 0;
  2781.     pre_read_weak_pair_buffers ();
  2782.   }
  2783.   return;
  2784. }
  2785.  
  2786. static void
  2787. DEFUN_VOID (flush_new_space_buffer)
  2788. {
  2789.   if (weak_pair_buffer_position == -1)
  2790.     return;
  2791.   DUMP_BUFFER (weak_pair_buffer, weak_pair_buffer_position,
  2792.            gc_buffer_bytes, ((Boolean *) NULL),
  2793.            "the weak pair buffer");
  2794.   weak_pair_buffer_position = -1;
  2795.   return;
  2796. }
  2797.  
  2798. static SCHEME_OBJECT *
  2799. DEFUN (guarantee_in_memory, (addr), SCHEME_OBJECT * addr)
  2800. {
  2801.   long position, offset;
  2802.  
  2803.   if (addr >= Constant_Space)
  2804.     return (addr);
  2805.  
  2806.   position = (addr - aligned_heap);
  2807.   offset = (position & gc_buffer_mask);
  2808.   position = (position >> gc_buffer_shift);
  2809.   position = (position << gc_buffer_byte_shift);
  2810.   position += gc_file_start_position;
  2811.  
  2812.   if (position != weak_pair_buffer_position)
  2813.   {
  2814.     flush_new_space_buffer ();
  2815.     LOAD_BUFFER (weak_pair_buffer, position, gc_buffer_bytes,
  2816.          "the weak pair buffer");
  2817.     weak_pair_buffer_position = position;
  2818.     if (weak_pair_break != EMPTY_LIST)
  2819.     {
  2820.       weak_buffer_pre_read_count -= 1;
  2821.       pre_read_weak_pair_buffers ();
  2822.     }
  2823.   }
  2824.   return ((GC_BUFFER_BOTTOM (weak_pair_buffer)) + offset);
  2825. }
  2826.  
  2827. /* For a description of the algorithm, see memmag.c and gccode.h.
  2828.    This has been modified only to account for the fact that new space
  2829.    is on disk.  Old space is in memory.
  2830.    Note: Compiled_BH requires the names Temp and Old!
  2831. */
  2832.  
  2833. static SCHEME_OBJECT
  2834. DEFUN (update_weak_pointer, (Temp), SCHEME_OBJECT Temp)
  2835. {
  2836.   SCHEME_OBJECT * Old;
  2837.  
  2838.   switch (GC_Type (Temp))
  2839.   {
  2840.     case GC_Non_Pointer:
  2841.       return (Temp);
  2842.   
  2843.     case GC_Special:
  2844.       if ((OBJECT_TYPE (Temp)) != TC_REFERENCE_TRAP)
  2845.     /* No other special type makes sense here. */
  2846.     goto fail;
  2847.       if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
  2848.     return (Temp);
  2849.       /* Otherwise, it is a pointer.  Fall through */
  2850.  
  2851.     /* Normal pointer types, the broken heart is in the first word.
  2852.        Note that most special types are treated normally here.
  2853.        The BH code updates *Scan if the object has been relocated.
  2854.        Otherwise it falls through and we replace it with a full SHARP_F.
  2855.        Eliminating this assignment would keep old data (pl. of datum).
  2856.      */
  2857.     case GC_Cell:
  2858.     case GC_Pair:
  2859.     case GC_Triple:
  2860.     case GC_Quadruple:
  2861.     case GC_Vector:
  2862.       Old = (OBJECT_ADDRESS (Temp));
  2863.       if (Old >= Constant_Space)
  2864.     return (Temp);
  2865.  
  2866.       if ((OBJECT_TYPE (*Old)) == TC_BROKEN_HEART)
  2867.     return (MAKE_OBJECT_FROM_OBJECTS (Temp, *Old));
  2868.       else
  2869.     return (SHARP_F);
  2870.  
  2871.     case GC_Compiled:
  2872.       Old = (OBJECT_ADDRESS (Temp));
  2873.       if (Old >= Constant_Space)
  2874.     return (Temp);
  2875.       Compiled_BH (false, { return Temp; });
  2876.       return (SHARP_F);
  2877.  
  2878.     default:            /* Non Marked Headers and Broken Hearts */
  2879.     case GC_Undefined:
  2880.     fail:
  2881.       fprintf (stderr,
  2882.            "\n%s (update_weak_pointer): Clearing bad object 0x%08lx.\n",
  2883.            scheme_program_name, Temp);
  2884.       fflush (stderr);
  2885.       return (SHARP_F);
  2886.   }
  2887. }
  2888.  
  2889. SCHEME_OBJECT
  2890.   Weak_Chain,
  2891.   * weak_pair_stack_ptr,
  2892.   * weak_pair_stack_limit;
  2893.  
  2894. void
  2895. DEFUN (initialize_weak_pair_transport, (limit), SCHEME_OBJECT * limit)
  2896. {
  2897.   Weak_Chain = EMPTY_LIST;
  2898.   weak_pair_stack_ptr = Stack_Pointer;
  2899.   weak_pair_stack_limit = (limit + 1); /* in case it's odd */
  2900.   return;
  2901. }
  2902.  
  2903. void
  2904. DEFUN_VOID (fix_weak_chain_1)
  2905. {
  2906.   fast SCHEME_OBJECT chain, * old_weak_cell, * scan, * ptr, * limit;
  2907.  
  2908.   chain = Weak_Chain;
  2909.   initialize_new_space_buffer (chain);
  2910.  
  2911.   limit = Stack_Pointer;
  2912.   for (ptr = weak_pair_stack_ptr; ptr < limit ; ptr += 2)
  2913.     *ptr = (update_weak_pointer (*ptr));
  2914.  
  2915.   while (chain != EMPTY_LIST)
  2916.   {
  2917.     old_weak_cell = (OBJECT_ADDRESS (Weak_Chain));
  2918.     scan = (guarantee_in_memory (OBJECT_ADDRESS (*old_weak_cell++)));
  2919.     Weak_Chain = (* old_weak_cell);
  2920.     *scan = (update_weak_pointer
  2921.          (MAKE_OBJECT_FROM_OBJECTS (Weak_Chain, (* scan))));
  2922.     Weak_Chain = (OBJECT_NEW_TYPE (TC_NULL, Weak_Chain));
  2923.   }
  2924.   flush_new_space_buffer ();
  2925.   Weak_Chain = chain;
  2926.   return;
  2927. }
  2928.  
  2929. void
  2930. DEFUN_VOID (fix_weak_chain_2)
  2931. {
  2932.   fast SCHEME_OBJECT * ptr, * limit, new_car, * addr;
  2933.  
  2934.   limit = Stack_Pointer;
  2935.   for (ptr = weak_pair_stack_ptr; ptr < limit ; )
  2936.   {
  2937.     new_car = *ptr++;
  2938.     addr = ((SCHEME_OBJECT *) (*ptr++));
  2939.     if (new_car != SHARP_F)
  2940.       *addr = new_car;
  2941.   }
  2942.   weak_pair_stack_ptr = limit;
  2943.   return;
  2944. }
  2945.  
  2946. /* Here is the set up for the full garbage collection:
  2947.  
  2948.    - First it makes the constant space and stack into one large area
  2949.    by "hiding" the gap between them with a non-marked header.
  2950.  
  2951.    - Then it saves away all the relevant microcode registers into new
  2952.    space, making this the root for garbage collection.
  2953.  
  2954.    - Then it does the actual garbage collection in 4 steps:
  2955.      1) Trace constant space.
  2956.      2) Trace objects pointed out by the root and constant space.
  2957.      3) Trace the precious objects, remembering where consing started.
  2958.      4) Update all weak pointers.
  2959.  
  2960.    - Load new space to memory.
  2961.  
  2962.    - Finally it restores the microcode registers from the copies in
  2963.    new space.
  2964. */
  2965.  
  2966. void
  2967. DEFUN (GC, (weak_pair_transport_initialized_p),
  2968.        int weak_pair_transport_initialized_p)
  2969. {
  2970.   SCHEME_OBJECT
  2971.     * root, * result, * end_of_constant_area,
  2972.     the_precious_objects, * root2,
  2973.     * free_buffer, * block_start, * initial_free_buffer;
  2974.  
  2975.   if (!weak_pair_transport_initialized_p)
  2976.     initialize_weak_pair_transport (Free_Constant + 2);
  2977.  
  2978.   free_buffer = (initialize_free_buffer ());
  2979.   Free = Heap_Bottom;
  2980.   block_start = aligned_heap;
  2981.   if (block_start != Free)
  2982.     free_buffer += (Free - block_start);
  2983.   initial_free_buffer = free_buffer;
  2984.  
  2985.   SET_MEMTOP (Heap_Top - GC_Reserve);
  2986.  
  2987.   /* Save the microcode registers so that they can be relocated */
  2988.  
  2989.   Terminate_Old_Stacklet ();
  2990.   SEAL_CONSTANT_SPACE ();
  2991.   end_of_constant_area = (CONSTANT_SPACE_SEAL ());
  2992.   root = Free;
  2993.   the_precious_objects = (Get_Fixed_Obj_Slot (Precious_Objects));
  2994.   Set_Fixed_Obj_Slot (Precious_Objects, SHARP_F);
  2995.   Set_Fixed_Obj_Slot (Lost_Objects_Base, SHARP_F);
  2996.  
  2997.   *free_buffer++ = Fixed_Objects;
  2998.   *free_buffer++ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History));
  2999.   *free_buffer++ = Undefined_Primitives;
  3000.   *free_buffer++ = Undefined_Primitives_Arity;
  3001.   *free_buffer++ = Get_Current_Stacklet ();
  3002.   *free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ?
  3003.             SHARP_F :
  3004.             (MAKE_POINTER_OBJECT (TC_CONTROL_POINT,
  3005.                       Prev_Restore_History_Stacklet)));
  3006.  
  3007.   *free_buffer++ = Current_State_Point;
  3008.   *free_buffer++ = Fluid_Bindings;
  3009.   Free += (free_buffer - initial_free_buffer);
  3010.  
  3011.   if (free_buffer >= free_buffer_top)
  3012.     free_buffer =
  3013.       (dump_and_reset_free_buffer ((free_buffer - free_buffer_top),
  3014.                    NULL));
  3015.   /* The 4 step GC */
  3016.  
  3017.   result = (GCLoop (Constant_Space, &free_buffer, &Free));
  3018.   if (result != end_of_constant_area)
  3019.   {
  3020.     fprintf (stderr,
  3021.          "\n%s (GC): The Constant Space scan ended too early.\n",
  3022.          scheme_program_name);
  3023.     fflush (stderr);
  3024.     Microcode_Termination (TERM_EXIT);
  3025.     /*NOTREACHED*/
  3026.   }
  3027.  
  3028.   result = (GCLoop (((initialize_scan_buffer (block_start))
  3029.              + (Heap_Bottom - block_start)),
  3030.             &free_buffer, &Free));
  3031.   if (free_buffer != result)
  3032.   {
  3033.     fprintf (stderr,
  3034.          "\n%s (GC): The Heap scan ended too early.\n",
  3035.          scheme_program_name);
  3036.     fflush (stderr);
  3037.     Microcode_Termination (TERM_EXIT);
  3038.     /*NOTREACHED*/
  3039.   }
  3040.  
  3041.   root2 = Free;
  3042.   *free_buffer++ = the_precious_objects;
  3043.   Free += (free_buffer - result);
  3044.   if (free_buffer >= free_buffer_top)
  3045.     free_buffer =
  3046.       (dump_and_reset_free_buffer ((free_buffer - free_buffer_top), NULL));
  3047.  
  3048.   result = (GCLoop (result, &free_buffer, &Free));
  3049.   if (free_buffer != result)
  3050.   {
  3051.     fprintf (stderr,
  3052.          "\n%s (GC): The Precious Object scan ended too early.\n",
  3053.          scheme_program_name);
  3054.     fflush (stderr);
  3055.     Microcode_Termination (TERM_EXIT);
  3056.     /*NOTREACHED*/
  3057.   }
  3058.   end_transport (NULL);
  3059.   fix_weak_chain_1 ();
  3060.  
  3061.   /* Load new space into memory. */
  3062.  
  3063.   final_reload (block_start, (Free - block_start), "new space");
  3064.   fix_weak_chain_2 ();
  3065.  
  3066.   /* Make the microcode registers point to the copies in new-space. */
  3067.  
  3068.   Fixed_Objects = *root++;
  3069.   Set_Fixed_Obj_Slot (Precious_Objects, *root2);
  3070.   Set_Fixed_Obj_Slot
  3071.     (Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (root2))));
  3072.  
  3073.   History = (OBJECT_ADDRESS (*root++));
  3074.   Undefined_Primitives = *root++;
  3075.   Undefined_Primitives_Arity = *root++;
  3076.  
  3077.   Set_Current_Stacklet (*root);
  3078.   root += 1;
  3079.   if (*root == SHARP_F)
  3080.   {
  3081.     Prev_Restore_History_Stacklet = NULL;
  3082.     root += 1;
  3083.   }
  3084.   else
  3085.     Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (*root++));
  3086.   Current_State_Point = *root++;
  3087.   Fluid_Bindings = *root++;
  3088.   Free_Stacklets = NULL;
  3089.   COMPILER_TRANSPORT_END ();
  3090.   CLEAR_INTERRUPT (INT_GC);
  3091.   return;
  3092. }
  3093.  
  3094. /* (GARBAGE-COLLECT SLACK)
  3095.    Requests a garbage collection leaving the specified amount of slack
  3096.    for the top of heap check on the next GC.  The primitive ends by invoking
  3097.    the GC daemon if there is one.
  3098. */
  3099.  
  3100. DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0)
  3101. {
  3102.   long new_gc_reserve;
  3103.   extern unsigned long gc_counter;
  3104.   SCHEME_OBJECT GC_Daemon_Proc;
  3105.   PRIMITIVE_HEADER (1);
  3106.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  3107.  
  3108.   STACK_SANITY_CHECK ("GC");
  3109.   new_gc_reserve = (arg_nonnegative_integer (1));
  3110.   if (Free > Heap_Top)
  3111.     termination_gc_out_of_space ();
  3112.  
  3113.   ENTER_CRITICAL_SECTION ("garbage collector");
  3114.   gc_counter += 1;
  3115.   GC_Reserve = new_gc_reserve;
  3116.   GC (0);
  3117.   POP_PRIMITIVE_FRAME (1);
  3118.   GC_Daemon_Proc = (Get_Fixed_Obj_Slot (GC_Daemon));
  3119.  
  3120.   RENAME_CRITICAL_SECTION ("garbage collector daemon");
  3121.   if (GC_Daemon_Proc == SHARP_F)
  3122.   {
  3123.    Will_Push (CONTINUATION_SIZE);
  3124.     Store_Return (RC_NORMAL_GC_DONE);
  3125.     Store_Expression (LONG_TO_UNSIGNED_FIXNUM(MemTop - Free));
  3126.     Save_Cont ();
  3127.    Pushed ();
  3128.     PRIMITIVE_ABORT (PRIM_POP_RETURN);
  3129.     /*NOTREACHED*/
  3130.   }
  3131.  Will_Push (CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1));
  3132.   Store_Return (RC_NORMAL_GC_DONE);
  3133.   Store_Expression (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free));
  3134.   Save_Cont ();
  3135.   STACK_PUSH (GC_Daemon_Proc);
  3136.   STACK_PUSH (STACK_FRAME_HEADER);
  3137.  Pushed ();
  3138.   PRIMITIVE_ABORT (PRIM_APPLY);
  3139.   /* The following comment is by courtesy of LINT, your friendly sponsor. */
  3140.   /*NOTREACHED*/
  3141. }
  3142.  
  3143. static void
  3144. DEFUN_VOID (statistics_clear)
  3145. {
  3146.   int cntr, arlen;
  3147.   struct bch_GC_statistic * ptr;
  3148.  
  3149.   arlen = (((sizeof (all_gc_statistics))
  3150.         / (sizeof (struct bch_GC_statistic)))
  3151.        - 1);
  3152.   for (cntr = 0, ptr = &all_gc_statistics[0]; cntr < arlen; cntr++, ptr++)
  3153.     (* (ptr->counter)) = 0;
  3154.   return;
  3155. }
  3156.  
  3157. static int statistics_print_level = 0;
  3158.  
  3159. static void
  3160. DEFUN (statistics_print, (level, noise), int level AND char * noise)
  3161. {
  3162.   char format[30];
  3163.   int cntr, arlen, len, name_len;
  3164.   struct bch_GC_statistic * ptr;
  3165.  
  3166.   if (level > statistics_print_level)
  3167.     return;
  3168.   arlen = (((sizeof (all_gc_statistics))
  3169.         / (sizeof (struct bch_GC_statistic)))
  3170.        - 1);
  3171.   name_len = -1;
  3172.   for (cntr = 0, ptr = &all_gc_statistics[0];
  3173.        cntr < arlen;
  3174.        cntr++, ptr++)
  3175.     if ((* (ptr->counter)) != 0L)
  3176.     {
  3177.       len = (strlen (ptr->name));
  3178.       if (len > name_len)
  3179.     name_len = len;
  3180.     }
  3181.  
  3182.   if (name_len >= 0)
  3183.   {
  3184.     sprintf (&format[0], "\t%%-%ds : %%ld\n", name_len);
  3185.  
  3186.     printf ("\nGC I/O statistics %s:\n", noise);
  3187.     for (cntr = 0, ptr = &all_gc_statistics[0]; cntr < arlen; cntr++, ptr++)
  3188.       if ((* (ptr->counter)) != 0L)
  3189.     printf (&format[0], ptr->name, (* (ptr->counter)));
  3190.     fflush (stdout);
  3191.   }
  3192.   return;
  3193. }
  3194.  
  3195. static SCHEME_OBJECT
  3196. DEFUN_VOID (statistics_names)
  3197. {
  3198.   SCHEME_OBJECT vector, * scan;
  3199.   struct bch_GC_statistic * ptr;
  3200.   int len, cntr;
  3201.  
  3202.   len = (((sizeof (all_gc_statistics))
  3203.       / (sizeof (struct bch_GC_statistic)))
  3204.      - 1);
  3205.   if (len == 0)
  3206.     return (SHARP_F);
  3207.  
  3208.   vector = (allocate_marked_vector (TC_VECTOR, len, true));
  3209.   for (cntr = 0, ptr = &all_gc_statistics[0], scan = (VECTOR_LOC (vector, 0));
  3210.        cntr < len;
  3211.        cntr++, ptr++)
  3212.     *scan++ = (char_pointer_to_string ((unsigned char *) ptr->name));
  3213.   return (vector);
  3214. }
  3215.  
  3216. static void
  3217. DEFUN_VOID (statistics_read)
  3218. {
  3219.   SCHEME_OBJECT vector, *scan;
  3220.   struct bch_GC_statistic * ptr;
  3221.   int len, cntr;
  3222.  
  3223.   len = (((sizeof (all_gc_statistics))
  3224.       / (sizeof (struct bch_GC_statistic)))
  3225.      - 1);
  3226.   if (len == 0)
  3227.     signal_error_from_primitive (ERR_UNDEFINED_PRIMITIVE);
  3228.  
  3229.   vector = (VECTOR_ARG (1));
  3230.   if (len != (VECTOR_LENGTH (vector)))
  3231.     error_bad_range_arg (1);
  3232.   
  3233.   for (cntr = 0, ptr = &all_gc_statistics[0], scan = (VECTOR_LOC (vector, 0));
  3234.        cntr < len;
  3235.        cntr++, ptr++)
  3236.     *scan++ = (long_to_integer (* (ptr->counter)));
  3237.   return;
  3238. }
  3239.  
  3240. /* Additional primitives for statistics collection and
  3241.    manipulation of parameters from Scheme
  3242.  */
  3243.  
  3244. DEFINE_PRIMITIVE ("BCHSCHEME-STATISTICS-NAMES", Prim_bchscheme_stat_names, 0, 0, 0)
  3245. {
  3246.   PRIMITIVE_HEADER (0);
  3247.   PRIMITIVE_RETURN (statistics_names ());
  3248. }
  3249.  
  3250. DEFINE_PRIMITIVE ("BCHSCHEME-STATISTICS-READ!", Prim_bchscheme_read_stats, 1, 1, 0)
  3251. {
  3252.   PRIMITIVE_HEADER (1);
  3253.   statistics_read ();
  3254.   PRIMITIVE_RETURN (UNSPECIFIC);
  3255. }
  3256.  
  3257. /* There are other parameters that could be set, especially the drone program
  3258.    to run, and the file to gc from, but...
  3259.  */
  3260.  
  3261. #ifndef GET_SLEEP_DELTA
  3262. #define GET_SLEEP_DELTA()    -1
  3263. #define SET_SLEEP_DELTA(v)    do { } while (0)
  3264. #endif
  3265.  
  3266. #define N_PARAMS    6
  3267.  
  3268. DEFINE_PRIMITIVE ("BCHSCHEME-PARAMETERS-GET", Prim_bchscheme_get_params, 0, 0, 0)
  3269. {
  3270.   SCHEME_OBJECT vector;
  3271.   PRIMITIVE_HEADER (0);
  3272.  
  3273.   vector = (allocate_marked_vector (TC_VECTOR, N_PARAMS, true));
  3274.  
  3275.   VECTOR_SET (vector, 0,
  3276.           (long_to_integer ((long) CAN_RECONFIGURE_GC_BUFFERS)));
  3277.   VECTOR_SET (vector, 1, (long_to_integer ((long) gc_buffer_size)));
  3278.   VECTOR_SET (vector, 2, (long_to_integer ((long) read_overlap)));
  3279.   VECTOR_SET (vector, 3, (long_to_integer ((long) write_overlap)));
  3280.   VECTOR_SET (vector, 4, (long_to_integer ((long) (GET_SLEEP_DELTA ()))));
  3281.   VECTOR_SET (vector, 5, (char_pointer_to_string
  3282.               ((unsigned char *) drone_file_name)));
  3283.  
  3284.   PRIMITIVE_RETURN (vector);
  3285. }
  3286.  
  3287. static long
  3288. DEFUN (bchscheme_long_parameter, (vector, index),
  3289.        SCHEME_OBJECT vector AND int index)
  3290. {
  3291.   SCHEME_OBJECT temp;
  3292.   long value;
  3293.  
  3294.   temp = (VECTOR_REF (vector, index));
  3295.   if ((! (INTEGER_P (temp))) || (! (integer_to_long_p (temp))))
  3296.     error_bad_range_arg (1);
  3297.   value = (integer_to_long (temp));
  3298.   if (value < 0)
  3299.     error_bad_range_arg (1);
  3300.   return (value);
  3301. }
  3302.  
  3303. DEFINE_PRIMITIVE ("BCHSCHEME-PARAMETERS-SET!", Prim_bchscheme_set_params, 1, 1, 0)
  3304. {
  3305.   PRIMITIVE_HEADER (1);
  3306.  
  3307. #if (CAN_RECONFIGURE_GC_BUFFERS == 0)
  3308.   signal_error_from_primitive (ERR_UNDEFINED_PRIMITIVE);
  3309.   /*NOTREACHED*/
  3310. #else
  3311.  
  3312.   {
  3313.     char * new_drone_ptr;
  3314.     SCHEME_OBJECT vector, new_drone;
  3315.     int power;
  3316.     long
  3317.       new_buffer_size, new_read_overlap,
  3318.       new_write_overlap, new_sleep_period;
  3319.  
  3320.     vector = (VECTOR_ARG (1));
  3321.     if ((VECTOR_LENGTH (vector)) != N_PARAMS)
  3322.       error_bad_range_arg (1);
  3323.  
  3324.     /* Slot 0 ignored. */
  3325.     new_buffer_size = (bchscheme_long_parameter (vector, 1));
  3326.     new_read_overlap = (bchscheme_long_parameter (vector, 2));
  3327.     new_write_overlap = (bchscheme_long_parameter (vector, 3));
  3328.     new_sleep_period = (bchscheme_long_parameter (vector, 4));
  3329.     new_drone = (VECTOR_REF (vector, 5));
  3330.     if (! (STRING_P (new_drone)))
  3331.       error_bad_range_arg (1);
  3332.     if ((STRING_LENGTH (new_drone)) == 0)
  3333.       new_drone_ptr = ((char *) NULL);
  3334.     else
  3335.     {
  3336.       new_drone_ptr = ((char *) (malloc ((STRING_LENGTH (new_drone)) + 1)));
  3337.       if (new_drone_ptr != ((char *) NULL))
  3338.     strcpy (new_drone_ptr, ((char *) (STRING_LOC (new_drone, 0))));
  3339.     }
  3340.  
  3341.     power = (next_exponent_of_two (new_buffer_size));
  3342.     if (((1L << power) != new_buffer_size)
  3343.     || ((set_gc_buffer_sizes (power)) != 0))
  3344.       error_bad_range_arg (1);
  3345.  
  3346.     BUFFER_SHUTDOWN (0);
  3347.     SET_SLEEP_DELTA (new_sleep_period);
  3348.     if ((drone_file_name != ((char *) NULL))
  3349.     && (drone_file_name != option_gc_drone))
  3350.       free ((PTR) drone_file_name);
  3351.  
  3352.     if ((RE_INITIALIZE_GC_BUFFERS (0,
  3353.                    (Highest_Allocated_Address + 1),
  3354.                    (saved_heap_size
  3355.                     * (sizeof (SCHEME_OBJECT))),
  3356.                    new_read_overlap,
  3357.                    new_write_overlap,
  3358.                    new_drone_ptr)) == 0)
  3359.       PRIMITIVE_RETURN (UNSPECIFIC);
  3360.     else
  3361.     {
  3362.       BUFFER_SHUTDOWN (0);
  3363.       if (new_drone_ptr != ((char *) NULL))
  3364.     free (new_drone_ptr);
  3365.  
  3366.       if ((RE_INITIALIZE_GC_BUFFERS (0,
  3367.                      (Highest_Allocated_Address + 1),
  3368.                      (saved_heap_size
  3369.                       * (sizeof (SCHEME_OBJECT))),
  3370.                      0, 0,
  3371.                      option_gc_drone)) != 0)
  3372.     Microcode_Termination (TERM_EXIT);
  3373.       else
  3374.     signal_error_from_primitive (ERR_EXTERNAL_RETURN);
  3375.     }
  3376.     /*NOTREACHED*/
  3377.   }
  3378. #endif /* (CAN_RECONFIGURE_GC_BUFFERS == 0) */
  3379. }
  3380.